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.0305";
  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{ \( (?: (?> [^()]+ ) | (??{ $nested }) )* \) }x;
 152 my $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\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/##s; # incase specified as lib/*.pm
 179         if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
 180             my ($dir,$name) = (/(.*])(.*)/s);
 181             $dir =~ s/.*lib[\.\]]//s;
 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|/\z||;
 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\z/);
 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     if ($subname) {
 356         print OUT @cache,"1;\n# end of $last_package\::$subname\n";
 357         close(OUT);
 358     }
 359     close(IN);
 360
 361     if (!$keep){  # don't keep any obsolete *.al files in the directory
 362         my(%outfiles);
 363         # @outfiles{@outfiles} = @outfiles;
 364         # perl downcases all filenames on VMS (which upcases all filenames) so
 365         # we'd better downcase the sub name list too, or subs with upper case
 366         # letters in them will get their .al files deleted right after they're
 367         # created. (The mixed case sub name won't match the all-lowercase
 368         # filename, and so be cleaned up as a scrap file)
 369         if ($Is_VMS or $Is83) {
 370             %outfiles = map {lc($_) => lc($_) } @outfiles;
 371         } else {
 372             @outfiles{@outfiles} = @outfiles;
 373         }
 374         my(%outdirs,@outdirs);
 375         for (@outfiles) {
 376             $outdirs{File::Basename::dirname($_)}||=1;
 377         }
 378         for my $dir (keys %outdirs) {
 379             opendir(OUTDIR,$dir);
 380             foreach (sort readdir(OUTDIR)){
 381                 next unless /\.al\z/;
 382                 my($file) = "$dir/$_";
 383                 $file = lc $file if $Is83 or $Is_VMS;
 384                 next if $outfiles{$file};
 385                 print "  deleting $file\n" if ($Verbose>=2);
 386                 my($deleted,$thistime);  # catch all versions on VMS
 387                 do { $deleted += ($thistime = unlink $file) } while ($thistime);
 388                 carp "Unable to delete $file: $!" unless $deleted;
 389             }
 390             closedir(OUTDIR);
 391         }
 392     }
 393
 394     open(TS,">$al_idx_file") or
 395         carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!";
 396     print TS "# Index created by AutoSplit for $filename\n";
 397     print TS "#    (file acts as timestamp)\n";
 398     $last_package = '';
 399     for my $fqs (@subnames) {
 400         my($subname) = $fqs;
 401         $subname =~ s/.*:://;
 402         print TS "package $package{$fqs};\n"
 403             unless $last_package eq $package{$fqs};
 404         print TS "sub $subname $proto{$fqs};\n";
 405         $last_package = $package{$fqs};
 406     }
 407     print TS "1;\n";
 408     close(TS);
 409
 410     _check_unique($filename, $Maxlen, 1, @outfiles);
 411
 412     @outfiles;
 413 }
 414
 415 sub _modpname ($) {
 416     my($package) = @_;
 417     my $modpname = $package;
 418     if ($^O eq 'MSWin32') {
 419         $modpname =~ s#::#\\#g;
 420     } else {
 421         $modpname =~ s#::#/#g;
 422     }
 423     $modpname;
 424 }
 425
 426 sub _check_unique {
 427     my($filename, $maxlen, $warn, @outfiles) = @_;
 428     my(%notuniq) = ();
 429     my(%shorts)  = ();
 430     my(@toolong) = grep(
 431                         length(File::Basename::basename($_))
 432                         > $maxlen,
 433                         @outfiles
 434                        );
 435
 436     foreach (@toolong){
 437         my($dir) = File::Basename::dirname($_);
 438         my($file) = File::Basename::basename($_);
 439         my($trunc) = substr($file,0,$maxlen);
 440         $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
 441         $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
 442             "$shorts{$dir}{$trunc}, $file" : $file;
 443     }
 444     if (%notuniq && $warn){
 445         print "$filename: some names are not unique when " .
 446             "truncated to $maxlen characters:\n";
 447         foreach my $dir (sort keys %notuniq){
 448             print " directory $dir:\n";
 449             foreach my $trunc (sort keys %{$notuniq{$dir}}) {
 450                 print "  $shorts{$dir}{$trunc} truncate to $trunc\n";
 451             }
 452         }
 453     }
 454 }
 455
 456 1;
 457 __END__
 458
 459 # test functions so AutoSplit.pm can be applied to itself:
 460 sub test1 ($)   { "test 1\n"; }
 461 sub test2 ($$)  { "test 2\n"; }
 462 sub test3 ($$$) { "test 3\n"; }
 463 sub testtesttesttest4_1  { "test 4\n"; }
 464 sub testtesttesttest4_2  { "duplicate test 4\n"; }
 465 sub Just::Another::test5 { "another test 5\n"; }
 466 sub test6       { return join ":", __FILE__,__LINE__; }
 467 package Yet::Another::AutoSplit;
 468 sub testtesttesttest4_1 ($)  { "another test 4\n"; }
 469 sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
 470 package Yet::More::Attributes;
 471 sub test_a1 ($) : locked :locked { 1; }
 472 sub test_a2 : locked { 1; }