lib/AutoSplit.pm

   1 package AutoSplit;
   2
   3 use 5.005_64;
   4 use Exporter ();
   5 use Config qw(%Config);
   6 use Carp qw(carp);
   7 use File::Basename ();
   8 use File::Path qw(mkpath);
   9 use strict;
  10 our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
  11     $CheckForAutoloader, $CheckModTime);
  12
  13 $VERSION = "1.0304";
  14 @ISA = qw(Exporter);
  15 @EXPORT = qw(&autosplit &autosplit_lib_modules);
  16 @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
  17
  18 =head1 NAME
  19
  20 AutoSplit - split a package for autoloading
  21
  22 =head1 SYNOPSIS
  23
  24  autosplit($file, $dir, $keep, $check, $modtime);
  25
  26  autosplit_lib_modules(@modules);
  27
  28 =head1 DESCRIPTION
  29
  30 This function will split up your program into files that the AutoLoader
  31 module can handle. It is used by both the standard perl libraries and by
  32 the MakeMaker utility, to automatically configure libraries for autoloading.
  33
  34 The C<autosplit> interface splits the specified file into a hierarchy
  35 rooted at the directory C<$dir>. It creates directories as needed to reflect
  36 class hierarchy, and creates the file F<autosplit.ix>. This file acts as
  37 both forward declaration of all package routines, and as timestamp for the
  38 last update of the hierarchy.
  39
  40 The remaining three arguments to C<autosplit> govern other options to
  41 the autosplitter.
  42
  43 =over 2
  44
  45 =item $keep
  46
  47 If the third argument, I<$keep>, is false, then any
  48 pre-existing C<*.al> files in the autoload directory are removed if
  49 they are no longer part of the module (obsoleted functions).
  50 $keep defaults to 0.
  51
  52 =item $check
  53
  54 The
  55 fourth argument, I<$check>, instructs C<autosplit> to check the module
  56 currently being split to ensure that it does include a C<use>
  57 specification for the AutoLoader module, and skips the module if
  58 AutoLoader is not detected.
  59 $check defaults to 1.
  60
  61 =item $modtime
  62
  63 Lastly, the I<$modtime> argument specifies
  64 that C<autosplit> is to check the modification time of the module
  65 against that of the C<autosplit.ix> file, and only split the module if
  66 it is newer.
  67 $modtime defaults to 1.
  68
  69 =back
  70
  71 Typical use of AutoSplit in the perl MakeMaker utility is via the command-line
  72 with:
  73
  74  perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)'
  75
  76 Defined as a Make macro, it is invoked with file and directory arguments;
  77 C<autosplit> will split the specified file into the specified directory and
  78 delete obsolete C<.al> files, after checking first that the module does use
  79 the AutoLoader, and ensuring that the module is not already currently split
  80 in its current form (the modtime test).
  81
  82 The C<autosplit_lib_modules> form is used in the building of perl. It takes
  83 as input a list of files (modules) that are assumed to reside in a directory
  84 B<lib> relative to the current directory. Each file is sent to the
  85 autosplitter one at a time, to be split into the directory B<lib/auto>.
  86
  87 In both usages of the autosplitter, only subroutines defined following the
  88 perl I<__END__> token are split out into separate files. Some
  89 routines may be placed prior to this marker to force their immediate loading
  90 and parsing.
  91
  92 =head2 Multiple packages
  93
  94 As of version 1.01 of the AutoSplit module it is possible to have
  95 multiple packages within a single file. Both of the following cases
  96 are supported:
  97
  98    package NAME;
  99    __END__
 100    sub AAA { ... }
 101    package NAME::option1;
 102    sub BBB { ... }
 103    package NAME::option2;
 104    sub BBB { ... }
 105
 106    package NAME;
 107    __END__
 108    sub AAA { ... }
 109    sub NAME::option1::BBB { ... }
 110    sub NAME::option2::BBB { ... }
 111
 112 =head1 DIAGNOSTICS
 113
 114 C<AutoSplit> will inform the user if it is necessary to create the
 115 top-level directory specified in the invocation. It is preferred that
 116 the script or installation process that invokes C<AutoSplit> have
 117 created the full directory path ahead of time. This warning may
 118 indicate that the module is being split into an incorrect path.
 119
 120 C<AutoSplit> will warn the user of all subroutines whose name causes
 121 potential file naming conflicts on machines with drastically limited
 122 (8 characters or less) file name length. Since the subroutine name is
 123 used as the file name, these warnings can aid in portability to such
 124 systems.
 125
 126 Warnings are issued and the file skipped if C<AutoSplit> cannot locate
 127 either the I<__END__> marker or a "package Name;"-style specification.
 128
 129 C<AutoSplit> will also emit general diagnostics for inability to
 130 create directories or files.
 131
 132 =cut
 133
 134 # for portability warn about names longer than $maxlen
 135 $Maxlen  = 8;   # 8 for dos, 11 (14-".al") for SYSVR3
 136 $Verbose = 1;   # 0=none, 1=minimal, 2=list .al files
 137 $Keep    = 0;
 138 $CheckForAutoloader = 1;
 139 $CheckModTime = 1;
 140
 141 my $IndexFile = "autosplit.ix"; # file also serves as timestamp
 142 my $maxflen = 255;
 143 $maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
 144 if (defined (&Dos::UseLFN)) {
 145      $maxflen = Dos::UseLFN() ? 255 : 11;
 146 }
 147 my $Is_VMS = ($^O eq 'VMS');
 148
 149 # allow checking for valid ': attrlist' attachments
 150 my $nested;
 151 $nested = qr{ \( (?: (?> [^()]+ ) | (?p{ $nested }) )* \) }x;
 152 my $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) [\s,]* }x;
 153 my $attr_list = qr{ \s* : \s* (?: $one_attr )* }x;
 154
 155
 156
 157 sub autosplit{
 158     my($file, $autodir,  $keep, $ckal, $ckmt) = @_;
 159     # $file    - the perl source file to be split (after __END__)
 160     # $autodir - the ".../auto" dir below which to write split subs
 161     # Handle optional flags:
 162     $keep = $Keep unless defined $keep;
 163     $ckal = $CheckForAutoloader unless defined $ckal;
 164     $ckmt = $CheckModTime unless defined $ckmt;
 165     autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
 166 }
 167
 168
 169 # This function is used during perl building/installation
 170 # ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
 171
 172 sub autosplit_lib_modules{
 173     my(@modules) = @_; # list of Module names
 174
 175     while(defined($_ = shift @modules)){
 176         s#::#/#g;       # incase specified as ABC::XYZ
 177         s|\\|/|g;               # bug in ksh OS/2
 178         s#^lib/##; # incase specified as lib/*.pm
 179         if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
 180             my ($dir,$name) = (/(.*])(.*)/);
 181             $dir =~ s/.*lib[\.\]]//;
 182             $dir =~ s#[\.\]]#/#g;
 183             $_ = $dir . $name;
 184         }
 185         autosplit_file("lib/$_", "lib/auto",
 186                        $Keep, $CheckForAutoloader, $CheckModTime);
 187     }
 188     0;
 189 }
 190
 191
 192 # private functions
 193
 194 sub autosplit_file {
 195     my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
 196         = @_;
 197     my(@outfiles);
 198     local($_);
 199     local($/) = "\n";
 200
 201     # where to write output files
 202     $autodir ||= "lib/auto";
 203     if ($Is_VMS) {
 204         ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/$||;
 205         $filename = VMS::Filespec::unixify($filename); # may have dirs
 206     }
 207     unless (-d $autodir){
 208         mkpath($autodir,0,0755);
 209         # We should never need to create the auto dir
 210         # here. installperl (or similar) should have done
 211         # it. Expecting it to exist is a valuable sanity check against
 212         # autosplitting into some random directory by mistake.
 213         print "Warning: AutoSplit had to create top-level " .
 214             "$autodir unexpectedly.\n";
 215     }
 216
 217     # allow just a package name to be used
 218     $filename .= ".pm" unless ($filename =~ m/\.pm$/);
 219
 220     open(IN, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
 221     my($pm_mod_time) = (stat($filename))[9];
 222     my($autoloader_seen) = 0;
 223     my($in_pod) = 0;
 224     my($def_package,$last_package,$this_package,$fnr);
 225     while (<IN>) {
 226         # Skip pod text.
 227         $fnr++;
 228         $in_pod = 1 if /^=\w/;
 229         $in_pod = 0 if /^=cut/;
 230         next if ($in_pod || /^=cut/);
 231
 232         # record last package name seen
 233         $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
 234         ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
 235         ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
 236         last if /^__END__/;
 237     }
 238     if ($check_for_autoloader && !$autoloader_seen){
 239         print "AutoSplit skipped $filename: no AutoLoader used\n"
 240             if ($Verbose>=2);
 241         return 0;
 242     }
 243     $_ or die "Can't find __END__ in $filename\n";
 244
 245     $def_package or die "Can't find 'package Name;' in $filename\n";
 246
 247     my($modpname) = _modpname($def_package);
 248
 249     # this _has_ to match so we have a reasonable timestamp file
 250     die "Package $def_package ($modpname.pm) does not ".
 251         "match filename $filename"
 252             unless ($filename =~ m/\Q$modpname.pm\E$/ or
 253                     ($^O eq 'dos') or ($^O eq 'MSWin32') or
 254                     $Is_VMS && $filename =~ m/$modpname.pm/i);
 255
 256     my($al_idx_file) = "$autodir/$modpname/$IndexFile";
 257
 258     if ($check_mod_time){
 259         my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
 260         if ($al_ts_time >= $pm_mod_time){
 261             print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
 262                 if ($Verbose >= 2);
 263             return undef;       # one undef, not a list
 264         }
 265     }
 266
 267     print "AutoSplitting $filename ($autodir/$modpname)\n"
 268         if $Verbose;
 269
 270     unless (-d "$autodir/$modpname"){
 271         mkpath("$autodir/$modpname",0,0777);
 272     }
 273
 274     # We must try to deal with some SVR3 systems with a limit of 14
 275     # characters for file names. Sadly we *cannot* simply truncate all
 276     # file names to 14 characters on these systems because we *must*
 277     # create filenames which exactly match the names used by AutoLoader.pm.
 278     # This is a problem because some systems silently truncate the file
 279     # names while others treat long file names as an error.
 280
 281     my $Is83 = $maxflen==11;  # plain, case INSENSITIVE dos filenames
 282
 283     my(@subnames, $subname, %proto, %package);
 284     my @cache = ();
 285     my $caching = 1;
 286     $last_package = '';
 287     while (<IN>) {
 288         $fnr++;
 289         $in_pod = 1 if /^=\w/;
 290         $in_pod = 0 if /^=cut/;
 291         next if ($in_pod || /^=cut/);
 292         # the following (tempting) old coding gives big troubles if a
 293         # cut is forgotten at EOF:
 294         # next if /^=\w/ .. /^=cut/;
 295         if (/^package\s+([\w:]+)\s*;/) {
 296             $this_package = $def_package = $1;
 297         }
 298         if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
 299             print OUT "# end of $last_package\::$subname\n1;\n"
 300                 if $last_package;
 301             $subname = $1;
 302             my $proto = $2 || '';
 303             if ($subname =~ s/(.*):://){
 304                 $this_package = $1;
 305             } else {
 306                 $this_package = $def_package;
 307             }
 308             my $fq_subname = "$this_package\::$subname";
 309             $package{$fq_subname} = $this_package;
 310             $proto{$fq_subname} = $proto;
 311             push(@subnames, $fq_subname);
 312             my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
 313             $modpname = _modpname($this_package);
 314             mkpath("$autodir/$modpname",0,0777);
 315             my($lpath) = "$autodir/$modpname/$lname.al";
 316             my($spath) = "$autodir/$modpname/$sname.al";
 317             my $path;
 318             if (!$Is83 and open(OUT, ">$lpath")){
 319                 $path=$lpath;
 320                 print "  writing $lpath\n" if ($Verbose>=2);
 321             } else {
 322                 open(OUT, ">$spath") or die "Can't create $spath: $!\n";
 323                 $path=$spath;
 324                 print "  writing $spath (with truncated name)\n"
 325                         if ($Verbose>=1);
 326             }
 327             push(@outfiles, $path);
 328             print OUT <<EOT;
 329 # NOTE: Derived from $filename.
 330 # Changes made here will be lost when autosplit again.
 331 # See AutoSplit.pm.
 332 package $this_package;
 333
 334 #line $fnr "$filename (autosplit into $path)"
 335 EOT
 336             print OUT @cache;
 337             @cache = ();
 338             $caching = 0;
 339         }
 340         if($caching) {
 341             push(@cache, $_) if @cache || /\S/;
 342         } else {
 343             print OUT $_;
 344         }
 345         if(/^\}/) {
 346             if($caching) {
 347                 print OUT @cache;
 348                 @cache = ();
 349             }
 350             print OUT "\n";
 351             $caching = 1;
 352         }
 353         $last_package = $this_package if defined $this_package;
 354     }
 355     print OUT @cache,"1;\n# end of $last_package\::$subname\n";
 356     close(OUT);
 357     close(IN);
 358
 359     if (!$keep){  # don't keep any obsolete *.al files in the directory
 360         my(%outfiles);
 361         # @outfiles{@outfiles} = @outfiles;
 362         # perl downcases all filenames on VMS (which upcases all filenames) so
 363         # we'd better downcase the sub name list too, or subs with upper case
 364         # letters in them will get their .al files deleted right after they're
 365         # created. (The mixed case sub name won't match the all-lowercase
 366         # filename, and so be cleaned up as a scrap file)
 367         if ($Is_VMS or $Is83) {
 368             %outfiles = map {lc($_) => lc($_) } @outfiles;
 369         } else {
 370             @outfiles{@outfiles} = @outfiles;
 371         }
 372         my(%outdirs,@outdirs);
 373         for (@outfiles) {
 374             $outdirs{File::Basename::dirname($_)}||=1;
 375         }
 376         for my $dir (keys %outdirs) {
 377             opendir(OUTDIR,$dir);
 378             foreach (sort readdir(OUTDIR)){
 379                 next unless /\.al$/;
 380                 my($file) = "$dir/$_";
 381                 $file = lc $file if $Is83 or $Is_VMS;
 382                 next if $outfiles{$file};
 383                 print "  deleting $file\n" if ($Verbose>=2);
 384                 my($deleted,$thistime);  # catch all versions on VMS
 385                 do { $deleted += ($thistime = unlink $file) } while ($thistime);
 386                 carp "Unable to delete $file: $!" unless $deleted;
 387             }
 388             closedir(OUTDIR);
 389         }
 390     }
 391
 392     open(TS,">$al_idx_file") or
 393         carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!";
 394     print TS "# Index created by AutoSplit for $filename\n";
 395     print TS "#    (file acts as timestamp)\n";
 396     $last_package = '';
 397     for my $fqs (@subnames) {
 398         my($subname) = $fqs;
 399         $subname =~ s/.*:://;
 400         print TS "package $package{$fqs};\n"
 401             unless $last_package eq $package{$fqs};
 402         print TS "sub $subname $proto{$fqs};\n";
 403         $last_package = $package{$fqs};
 404     }
 405     print TS "1;\n";
 406     close(TS);
 407
 408     _check_unique($filename, $Maxlen, 1, @outfiles);
 409
 410     @outfiles;
 411 }
 412
 413 sub _modpname ($) {
 414     my($package) = @_;
 415     my $modpname = $package;
 416     if ($^O eq 'MSWin32') {
 417         $modpname =~ s#::#\\#g;
 418     } else {
 419         $modpname =~ s#::#/#g;
 420     }
 421     $modpname;
 422 }
 423
 424 sub _check_unique {
 425     my($filename, $maxlen, $warn, @outfiles) = @_;
 426     my(%notuniq) = ();
 427     my(%shorts)  = ();
 428     my(@toolong) = grep(
 429                         length(File::Basename::basename($_))
 430                         > $maxlen,
 431                         @outfiles
 432                        );
 433
 434     foreach (@toolong){
 435         my($dir) = File::Basename::dirname($_);
 436         my($file) = File::Basename::basename($_);
 437         my($trunc) = substr($file,0,$maxlen);
 438         $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
 439         $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
 440             "$shorts{$dir}{$trunc}, $file" : $file;
 441     }
 442     if (%notuniq && $warn){
 443         print "$filename: some names are not unique when " .
 444             "truncated to $maxlen characters:\n";
 445         foreach my $dir (sort keys %notuniq){
 446             print " directory $dir:\n";
 447             foreach my $trunc (sort keys %{$notuniq{$dir}}) {
 448                 print "  $shorts{$dir}{$trunc} truncate to $trunc\n";
 449             }
 450         }
 451     }
 452 }
 453
 454 1;
 455 __END__
 456
 457 # test functions so AutoSplit.pm can be applied to itself:
 458 sub test1 ($)   { "test 1\n"; }
 459 sub test2 ($$)  { "test 2\n"; }
 460 sub test3 ($$$) { "test 3\n"; }
 461 sub testtesttesttest4_1  { "test 4\n"; }
 462 sub testtesttesttest4_2  { "duplicate test 4\n"; }
 463 sub Just::Another::test5 { "another test 5\n"; }
 464 sub test6       { return join ":", __FILE__,__LINE__; }
 465 package Yet::Another::AutoSplit;
 466 sub testtesttesttest4_1 ($)  { "another test 4\n"; }
 467 sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
 468 package Yet::More::Attributes;
 469 sub test_a1 ($) : locked { 1; }
 470 sub test_a2 : locked { 1; }