File Coverage

lib/AutoSplit.pm
Criterion Covered Total %
statement 18 209 8.6
branch 0 116 0.0
condition 0 54 0.0
subroutine 6 12 50.0
total 24 391 6.1


line stmt bran cond sub time code
1           package AutoSplit;
2            
3 1     1 152552 use Exporter ();
  1       0  
  1       32  
4 1     1 5 use Config qw(%Config);
  1       2  
  1       45  
5 1     1 5 use File::Basename ();
  1       3  
  1       21  
6 1     1 6 use File::Path qw(mkpath);
  1       2  
  1       87  
7 1     1 5 use File::Spec::Functions qw(curdir catfile catdir);
  1       2  
  1       137  
8 1     1 0 use strict;
  1       0  
  1       4533  
9           our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
10           $CheckForAutoloader, $CheckModTime);
11            
12           $VERSION = "1.06";
13           @ISA = qw(Exporter);
14           @EXPORT = qw(&autosplit &autosplit_lib_modules);
15           @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
16            
17           =head1 NAME
18            
19           AutoSplit - split a package for autoloading
20            
21           =head1 SYNOPSIS
22            
23           autosplit($file, $dir, $keep, $check, $modtime);
24            
25           autosplit_lib_modules(@modules);
26            
27           =head1 DESCRIPTION
28            
29           This function will split up your program into files that the AutoLoader
30           module can handle. It is used by both the standard perl libraries and by
31           the MakeMaker utility, to automatically configure libraries for autoloading.
32            
33           The C interface splits the specified file into a hierarchy
34           rooted at the directory C<$dir>. It creates directories as needed to reflect
35           class hierarchy, and creates the file F. This file acts as
36           both forward declaration of all package routines, and as timestamp for the
37           last update of the hierarchy.
38            
39           The remaining three arguments to C govern other options to
40           the autosplitter.
41            
42           =over 2
43            
44           =item $keep
45            
46           If the third argument, I<$keep>, is false, then any
47           pre-existing C<*.al> files in the autoload directory are removed if
48           they are no longer part of the module (obsoleted functions).
49           $keep defaults to 0.
50            
51           =item $check
52            
53           The
54           fourth argument, I<$check>, instructs C to check the module
55           currently being split to ensure that it includes a C
56           specification for the AutoLoader module, and skips the module if
57           AutoLoader is not detected.
58           $check defaults to 1.
59            
60           =item $modtime
61            
62           Lastly, the I<$modtime> argument specifies
63           that C is to check the modification time of the module
64           against that of the C file, and only split the module if
65           it is newer.
66           $modtime defaults to 1.
67            
68           =back
69            
70           Typical use of AutoSplit in the perl MakeMaker utility is via the command-line
71           with:
72            
73           perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)'
74            
75           Defined as a Make macro, it is invoked with file and directory arguments;
76           C will split the specified file into the specified directory and
77           delete obsolete C<.al> files, after checking first that the module does use
78           the AutoLoader, and ensuring that the module is not already currently split
79           in its current form (the modtime test).
80            
81           The C form is used in the building of perl. It takes
82           as input a list of files (modules) that are assumed to reside in a directory
83           B relative to the current directory. Each file is sent to the
84           autosplitter one at a time, to be split into the directory B.
85            
86           In both usages of the autosplitter, only subroutines defined following the
87           perl I<__END__> token are split out into separate files. Some
88           routines may be placed prior to this marker to force their immediate loading
89           and parsing.
90            
91           =head2 Multiple packages
92            
93           As of version 1.01 of the AutoSplit module it is possible to have
94           multiple packages within a single file. Both of the following cases
95           are supported:
96            
97           package NAME;
98           __END__
99           sub AAA { ... }
100           package NAME::option1;
101           sub BBB { ... }
102           package NAME::option2;
103           sub BBB { ... }
104            
105           package NAME;
106           __END__
107           sub AAA { ... }
108           sub NAME::option1::BBB { ... }
109           sub NAME::option2::BBB { ... }
110            
111           =head1 DIAGNOSTICS
112            
113           C will inform the user if it is necessary to create the
114           top-level directory specified in the invocation. It is preferred that
115           the script or installation process that invokes C have
116           created the full directory path ahead of time. This warning may
117           indicate that the module is being split into an incorrect path.
118            
119           C will warn the user of all subroutines whose name causes
120           potential file naming conflicts on machines with drastically limited
121           (8 characters or less) file name length. Since the subroutine name is
122           used as the file name, these warnings can aid in portability to such
123           systems.
124            
125           Warnings are issued and the file skipped if C cannot locate
126           either the I<__END__> marker or a "package Name;"-style specification.
127            
128           C will also emit general diagnostics for inability to
129           create directories or files.
130            
131           =head1 AUTHOR
132            
133           C is maintained by the perl5-porters. Please direct
134           any questions to the canonical mailing list. Anything that
135           is applicable to the CPAN release can be sent to its maintainer,
136           though.
137            
138           Author and Maintainer: The Perl5-Porters
139            
140           Maintainer of the CPAN release: Steffen Mueller
141            
142           =head1 COPYRIGHT AND LICENSE
143            
144           This package has been part of the perl core since the first release
145           of perl5. It has been released separately to CPAN so older installations
146           can benefit from bug fixes.
147            
148           This package has the same copyright and license as the perl core:
149            
150           Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
151           2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
152           by Larry Wall and others
153          
154           All rights reserved.
155          
156           This program is free software; you can redistribute it and/or modify
157           it under the terms of either:
158          
159           a) the GNU General Public License as published by the Free
160           Software Foundation; either version 1, or (at your option) any
161           later version, or
162          
163           b) the "Artistic License" which comes with this Kit.
164          
165           This program is distributed in the hope that it will be useful,
166           but WITHOUT ANY WARRANTY; without even the implied warranty of
167           MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
168           the GNU General Public License or the Artistic License for more details.
169          
170           You should have received a copy of the Artistic License with this
171           Kit, in the file named "Artistic". If not, I'll be glad to provide one.
172          
173           You should also have received a copy of the GNU General Public License
174           along with this program in the file named "Copying". If not, write to the
175           Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
176           02111-1307, USA or visit their web page on the internet at
177           http://www.gnu.org/copyleft/gpl.html.
178          
179           For those of you that choose to use the GNU General Public License,
180           my interpretation of the GNU General Public License is that no Perl
181           script falls under the terms of the GPL unless you explicitly put
182           said script under the terms of the GPL yourself. Furthermore, any
183           object code linked with perl does not automatically fall under the
184           terms of the GPL, provided such object code only adds definitions
185           of subroutines and variables, and does not otherwise impair the
186           resulting interpreter from executing any standard Perl script. I
187           consider linking in C subroutines in this manner to be the moral
188           equivalent of defining subroutines in the Perl language itself. You
189           may sell such an object file as proprietary provided that you provide
190           or offer to provide the Perl source, as specified by the GNU General
191           Public License. (This is merely an alternate way of specifying input
192           to the program.) You may also sell a binary produced by the dumping of
193           a running Perl script that belongs to you, provided that you provide or
194           offer to provide the Perl source as specified by the GPL. (The
195           fact that a Perl interpreter and your code are in the same binary file
196           is, in this case, a form of mere aggregation.) This is my interpretation
197           of the GPL. If you still have concerns or difficulties understanding
198           my intent, feel free to contact me. Of course, the Artistic License
199           spells all this out for your protection, so you may prefer to use that.
200            
201           =cut
202            
203           # for portability warn about names longer than $maxlen
204           $Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3
205           $Verbose = 1; # 0=none, 1=minimal, 2=list .al files
206           $Keep = 0;
207           $CheckForAutoloader = 1;
208           $CheckModTime = 1;
209            
210           my $IndexFile = "autosplit.ix"; # file also serves as timestamp
211           my $maxflen = 255;
212           $maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
213           if (defined (&Dos::UseLFN)) {
214           $maxflen = Dos::UseLFN() ? 255 : 11;
215           }
216           my $Is_VMS = ($^O eq 'VMS');
217            
218           # allow checking for valid ': attrlist' attachments.
219           # extra jugglery required to support both 5.8 and 5.9/5.10 features
220           # (support for 5.8 required for cross-compiling environments)
221            
222           my $attr_list =
223           $] >= 5.009005 ?
224           eval <<'__QR__'
225           qr{
226           \s* : \s*
227           (?:
228           # one attribute
229           (?> # no backtrack
230           (?! \d) \w+
231           (? \( (?: [^()]++ | (?&nested)++ )*+ \) ) ?
232           )
233           (?: \s* : \s* | \s+ (?! :) )
234           )*
235           }x
236           __QR__
237           :
238           do {
239           # In pre-5.9.5 world we have to do dirty tricks.
240           # (we use 'our' rather than 'my' here, due to the rather complex and buggy
241           # behaviour of lexicals with qr// and (??{$lex}) )
242           our $trick1; # yes, cannot our and assign at the same time.
243           $trick1 = qr{ \( (?: (?> [^()]+ ) | (??{ $trick1 }) )* \) }x;
244           our $trick2 = qr{ (?> (?! \d) \w+ (?:$trick1)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
245           qr{ \s* : \s* (?: $trick2 )* }x;
246           };
247            
248           sub autosplit{
249 0     0   my($file, $autodir, $keep, $ckal, $ckmt) = @_;
250           # $file - the perl source file to be split (after __END__)
251           # $autodir - the ".../auto" dir below which to write split subs
252           # Handle optional flags:
253 0 0       $keep = $Keep unless defined $keep;
254 0 0       $ckal = $CheckForAutoloader unless defined $ckal;
255 0 0       $ckmt = $CheckModTime unless defined $ckmt;
256 0         autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
257           }
258            
259           sub carp{
260 0     0   require Carp;
261 0         goto &Carp::carp;
262           }
263            
264           # This function is used during perl building/installation
265           # ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
266            
267           sub autosplit_lib_modules {
268 0     0   my(@modules) = @_; # list of Module names
269 0         local $_; # Avoid clobber.
270 0         while (defined($_ = shift @modules)) {
271 0         while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ
272 0         $_ = catfile($1, $2);
273           }
274 0         s|\\|/|g; # bug in ksh OS/2
275 0         s#^lib/##s; # incase specified as lib/*.pm
276 0         my($lib) = catfile(curdir(), "lib");
277 0 0       if ($Is_VMS) { # may need to convert VMS-style filespecs
278 0         $lib =~ s#^\[\]#.\/#;
279           }
280 0         s#^$lib\W+##s; # incase specified as ./lib/*.pm
281 0 0 0     if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
282 0         my ($dir,$name) = (/(.*])(.*)/s);
283 0         $dir =~ s/.*lib[\.\]]//s;
284 0         $dir =~ s#[\.\]]#/#g;
285 0         $_ = $dir . $name;
286           }
287 0         autosplit_file(catfile($lib, $_), catfile($lib, "auto"),
288           $Keep, $CheckForAutoloader, $CheckModTime);
289           }
290 0         0;
291           }
292            
293            
294           # private functions
295            
296           my $self_mod_time = (stat __FILE__)[9];
297            
298           sub autosplit_file {
299 0     0   my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
300           = @_;
301 0         my(@outfiles);
302 0         local($_);
303 0         local($/) = "\n";
304            
305           # where to write output files
306 0   0     $autodir ||= catfile(curdir(), "lib", "auto");
307 0 0       if ($Is_VMS) {
308 0         ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||;
309 0         $filename = VMS::Filespec::unixify($filename); # may have dirs
310           }
311 0 0       unless (-d $autodir){
312 0         mkpath($autodir,0,0755);
313           # We should never need to create the auto dir
314           # here. installperl (or similar) should have done
315           # it. Expecting it to exist is a valuable sanity check against
316           # autosplitting into some random directory by mistake.
317 0         print "Warning: AutoSplit had to create top-level " .
318           "$autodir unexpectedly.\n";
319           }
320            
321           # allow just a package name to be used
322 0 0       $filename .= ".pm" unless ($filename =~ m/\.pm\z/);
323            
324 0 0       open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
325 0         my($pm_mod_time) = (stat($filename))[9];
326 0         my($autoloader_seen) = 0;
327 0         my($in_pod) = 0;
328 0         my($def_package,$last_package,$this_package,$fnr);
329 0         while (<$in>) {
330           # Skip pod text.
331 0         $fnr++;
332 0 0       $in_pod = 1 if /^=\w/;
333 0 0       $in_pod = 0 if /^=cut/;
334 0 0 0     next if ($in_pod || /^=cut/);
335 0 0       next if /^\s*#/;
336            
337           # record last package name seen
338 0 0       $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
339 0 0       ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
340 0 0       ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
341 0 0       last if /^__END__/;
342           }
343 0 0 0     if ($check_for_autoloader && !$autoloader_seen){
344 0 0       print "AutoSplit skipped $filename: no AutoLoader used\n"
345           if ($Verbose>=2);
346 0         return 0;
347           }
348 0 0       $_ or die "Can't find __END__ in $filename\n";
349            
350 0 0       $def_package or die "Can't find 'package Name;' in $filename\n";
351            
352 0         my($modpname) = _modpname($def_package);
353            
354           # this _has_ to match so we have a reasonable timestamp file
355 0 0 0     die "Package $def_package ($modpname.pm) does not ".
      0      
      0      
      0      
      0      
356           "match filename $filename"
357           unless ($filename =~ m/\Q$modpname.pm\E$/ or
358           ($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or
359           $Is_VMS && $filename =~ m/$modpname.pm/i);
360            
361 0         my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);
362            
363 0 0       if ($check_mod_time){
364 0   0     my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
365 0 0 0     if ($al_ts_time >= $pm_mod_time and
366           $al_ts_time >= $self_mod_time){
367 0 0       print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
368           if ($Verbose >= 2);
369 0         return undef; # one undef, not a list
370           }
371           }
372            
373 0         my($modnamedir) = catdir($autodir, $modpname);
374 0 0       print "AutoSplitting $filename ($modnamedir)\n"
375           if $Verbose;
376            
377 0 0       unless (-d $modnamedir){
378 0         mkpath($modnamedir,0,0777);
379           }
380            
381           # We must try to deal with some SVR3 systems with a limit of 14
382           # characters for file names. Sadly we *cannot* simply truncate all
383           # file names to 14 characters on these systems because we *must*
384           # create filenames which exactly match the names used by AutoLoader.pm.
385           # This is a problem because some systems silently truncate the file
386           # names while others treat long file names as an error.
387            
388 0         my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames
389            
390 0         my(@subnames, $subname, %proto, %package);
391 0         my @cache = ();
392 0         my $caching = 1;
393 0         $last_package = '';
394 0         my $out;
395 0         while (<$in>) {
396 0         $fnr++;
397 0 0       $in_pod = 1 if /^=\w/;
398 0 0       $in_pod = 0 if /^=cut/;
399 0 0 0     next if ($in_pod || /^=cut/);
400           # the following (tempting) old coding gives big troubles if a
401           # cut is forgotten at EOF:
402           # next if /^=\w/ .. /^=cut/;
403 0 0       if (/^package\s+([\w:]+)\s*;/) {
404 0         $this_package = $def_package = $1;
405           }
406            
407 0 0       if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
408 0 0       print $out "# end of $last_package\::$subname\n1;\n"
409           if $last_package;
410 0         $subname = $1;
411 0   0     my $proto = $2 || '';
412 0 0       if ($subname =~ s/(.*):://){
413 0         $this_package = $1;
414           } else {
415 0         $this_package = $def_package;
416           }
417 0         my $fq_subname = "$this_package\::$subname";
418 0         $package{$fq_subname} = $this_package;
419 0         $proto{$fq_subname} = $proto;
420 0         push(@subnames, $fq_subname);
421 0         my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
422 0         $modpname = _modpname($this_package);
423 0         my($modnamedir) = catdir($autodir, $modpname);
424 0         mkpath($modnamedir,0,0777);
425 0         my($lpath) = catfile($modnamedir, "$lname.al");
426 0         my($spath) = catfile($modnamedir, "$sname.al");
427 0         my $path;
428            
429 0 0 0     if (!$Is83 and open($out, ">$lpath")){
430 0         $path=$lpath;
431 0 0       print " writing $lpath\n" if ($Verbose>=2);
432           } else {
433 0 0       open($out, ">$spath") or die "Can't create $spath: $!\n";
434 0         $path=$spath;
435 0 0       print " writing $spath (with truncated name)\n"
436           if ($Verbose>=1);
437           }
438 0         push(@outfiles, $path);
439 0         my $lineno = $fnr - @cache;
440 0         print $out <
441           # NOTE: Derived from $filename.
442           # Changes made here will be lost when autosplit is run again.
443           # See AutoSplit.pm.
444           package $this_package;
445            
446           #line $lineno "$filename (autosplit into $path)"
447           EOT
448 0         print $out @cache;
449 0         @cache = ();
450 0         $caching = 0;
451           }
452 0 0       if($caching) {
453 0 0 0     push(@cache, $_) if @cache || /\S/;
454           } else {
455 0         print $out $_;
456           }
457 0 0       if(/^\}/) {
458 0 0       if($caching) {
459 0         print $out @cache;
460 0         @cache = ();
461           }
462 0         print $out "\n";
463 0         $caching = 1;
464           }
465 0 0       $last_package = $this_package if defined $this_package;
466           }
467 0 0       if ($subname) {
468 0         print $out @cache,"1;\n# end of $last_package\::$subname\n";
469 0         close($out);
470           }
471 0         close($in);
472          
473 0 0       if (!$keep){ # don't keep any obsolete *.al files in the directory
474 0         my(%outfiles);
475           # @outfiles{@outfiles} = @outfiles;
476           # perl downcases all filenames on VMS (which upcases all filenames) so
477           # we'd better downcase the sub name list too, or subs with upper case
478           # letters in them will get their .al files deleted right after they're
479           # created. (The mixed case sub name won't match the all-lowercase
480           # filename, and so be cleaned up as a scrap file)
481 0 0 0     if ($Is_VMS or $Is83) {
482 0         %outfiles = map {lc($_) => lc($_) } @outfiles;
  0          
483           } else {
484 0         @outfiles{@outfiles} = @outfiles;
485           }
486 0         my(%outdirs,@outdirs);
487 0         for (@outfiles) {
488 0   0     $outdirs{File::Basename::dirname($_)}||=1;
489           }
490 0         for my $dir (keys %outdirs) {
491 0         opendir(my $outdir,$dir);
492 0         foreach (sort readdir($outdir)){
493 0 0       next unless /\.al\z/;
494 0         my($file) = catfile($dir, $_);
495 0 0 0     $file = lc $file if $Is83 or $Is_VMS;
496 0 0       next if $outfiles{$file};
497 0 0       print " deleting $file\n" if ($Verbose>=2);
498 0         my($deleted,$thistime); # catch all versions on VMS
499 0         do { $deleted += ($thistime = unlink $file) } while ($thistime);
  0          
500 0 0       carp ("Unable to delete $file: $!") unless $deleted;
501           }
502 0         closedir($outdir);
503           }
504           }
505            
506 0 0       open(my $ts,">$al_idx_file") or
507           carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!");
508 0         print $ts "# Index created by AutoSplit for $filename\n";
509 0         print $ts "# (file acts as timestamp)\n";
510 0         $last_package = '';
511 0         for my $fqs (@subnames) {
512 0         my($subname) = $fqs;
513 0         $subname =~ s/.*:://;
514 0 0       print $ts "package $package{$fqs};\n"
515           unless $last_package eq $package{$fqs};
516 0         print $ts "sub $subname $proto{$fqs};\n";
517 0         $last_package = $package{$fqs};
518           }
519 0         print $ts "1;\n";
520 0         close($ts);
521            
522 0         _check_unique($filename, $Maxlen, 1, @outfiles);
523            
524 0         @outfiles;
525           }
526            
527           sub _modpname ($) {
528 0     0   my($package) = @_;
529 0         my $modpname = $package;
530 0 0       if ($^O eq 'MSWin32') {
531 0         $modpname =~ s#::#\\#g;
532           } else {
533 0         my @modpnames = ();
534 0         while ($modpname =~ m#(.*?[^:])::([^:].*)#) {
535 0         push @modpnames, $1;
536 0         $modpname = $2;
537           }
538 0         $modpname = catfile(@modpnames, $modpname);
539           }
540 0 0       if ($Is_VMS) {
541 0         $modpname = VMS::Filespec::unixify($modpname); # may have dirs
542           }
543 0         $modpname;
544           }
545            
546           sub _check_unique {
547 0     0   my($filename, $maxlen, $warn, @outfiles) = @_;
548 0         my(%notuniq) = ();
549 0         my(%shorts) = ();
550 0         my(@toolong) = grep(
551           length(File::Basename::basename($_))
552           > $maxlen,
553           @outfiles
554           );
555            
556 0         foreach (@toolong){
557 0         my($dir) = File::Basename::dirname($_);
558 0         my($file) = File::Basename::basename($_);
559 0         my($trunc) = substr($file,0,$maxlen);
560 0 0       $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
561 0 0       $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
562           "$shorts{$dir}{$trunc}, $file" : $file;
563           }
564 0 0 0     if (%notuniq && $warn){
565 0         print "$filename: some names are not unique when " .
566           "truncated to $maxlen characters:\n";
567 0         foreach my $dir (sort keys %notuniq){
568 0         print " directory $dir:\n";
569 0         foreach my $trunc (sort keys %{$notuniq{$dir}}) {
  0          
570 0         print " $shorts{$dir}{$trunc} truncate to $trunc\n";
571           }
572           }
573           }
574           }
575            
576           1;
577           __END__