lib/AutoSplit.pm

   1 package AutoSplit;
   2
   3 use Exporter ();
   4 use Config qw(%Config);
   5 use File::Basename ();
   6 use File::Path qw(mkpath);
   7 use File::Spec::Functions qw(curdir catfile catdir);
   8 use strict;
   9 our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
  10     $CheckForAutoloader, $CheckModTime);
  11
  12 $VERSION = "1.05";
  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<autosplit> 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<autosplit.ix>. 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<autosplit> 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<autosplit> to check the module
  55 currently being split to ensure that it includes a C<use>
  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<autosplit> is to check the modification time of the module
  64 against that of the C<autosplit.ix> 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<autosplit> 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<autosplit_lib_modules> 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<lib> relative to the current directory. Each file is sent to the
  84 autosplitter one at a time, to be split into the directory B<lib/auto>.
  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<AutoSplit> 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<AutoSplit> 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<AutoSplit> 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<AutoSplit> cannot locate
 126 either the I<__END__> marker or a "package Name;"-style specification.
 127
 128 C<AutoSplit> will also emit general diagnostics for inability to
 129 create directories or files.
 130
 131 =head1 AUTHOR
 132
 133 C<AutoSplit> 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 <perl5-porters@perl.org>
 139
 140 Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org>
 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 by Larry Wall and others
 152
 153                             All rights reserved.
 154
 155     This program is free software; you can redistribute it and/or modify
 156     it under the terms of either:
 157
 158         a) the GNU General Public License as published by the Free
 159         Software Foundation; either version 1, or (at your option) any
 160         later version, or
 161
 162         b) the "Artistic License" which comes with this Kit.
 163
 164     This program is distributed in the hope that it will be useful,
 165     but WITHOUT ANY WARRANTY; without even the implied warranty of
 166     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either
 167     the GNU General Public License or the Artistic License for more details.
 168
 169     You should have received a copy of the Artistic License with this
 170     Kit, in the file named "Artistic".  If not, I'll be glad to provide one.
 171
 172     You should also have received a copy of the GNU General Public License
 173     along with this program in the file named "Copying". If not, write to the
 174     Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
 175     02111-1307, USA or visit their web page on the internet at
 176     http://www.gnu.org/copyleft/gpl.html.
 177
 178     For those of you that choose to use the GNU General Public License,
 179     my interpretation of the GNU General Public License is that no Perl
 180     script falls under the terms of the GPL unless you explicitly put
 181     said script under the terms of the GPL yourself.  Furthermore, any
 182     object code linked with perl does not automatically fall under the
 183     terms of the GPL, provided such object code only adds definitions
 184     of subroutines and variables, and does not otherwise impair the
 185     resulting interpreter from executing any standard Perl script.  I
 186     consider linking in C subroutines in this manner to be the moral
 187     equivalent of defining subroutines in the Perl language itself.  You
 188     may sell such an object file as proprietary provided that you provide
 189     or offer to provide the Perl source, as specified by the GNU General
 190     Public License.  (This is merely an alternate way of specifying input
 191     to the program.)  You may also sell a binary produced by the dumping of
 192     a running Perl script that belongs to you, provided that you provide or
 193     offer to provide the Perl source as specified by the GPL.  (The
 194     fact that a Perl interpreter and your code are in the same binary file
 195     is, in this case, a form of mere aggregation.)  This is my interpretation
 196     of the GPL.  If you still have concerns or difficulties understanding
 197     my intent, feel free to contact me.  Of course, the Artistic License
 198     spells all this out for your protection, so you may prefer to use that.
 199
 200 =cut
 201
 202 # for portability warn about names longer than $maxlen
 203 $Maxlen  = 8;   # 8 for dos, 11 (14-".al") for SYSVR3
 204 $Verbose = 1;   # 0=none, 1=minimal, 2=list .al files
 205 $Keep    = 0;
 206 $CheckForAutoloader = 1;
 207 $CheckModTime = 1;
 208
 209 my $IndexFile = "autosplit.ix"; # file also serves as timestamp
 210 my $maxflen = 255;
 211 $maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
 212 if (defined (&Dos::UseLFN)) {
 213      $maxflen = Dos::UseLFN() ? 255 : 11;
 214 }
 215 my $Is_VMS = ($^O eq 'VMS');
 216
 217 # allow checking for valid ': attrlist' attachments.
 218 # extra jugglery required to support both 5.8 and 5.9/5.10 features
 219 # (support for 5.8 required for cross-compiling environments)
 220
 221 my $attr_list =
 222   $] >= 5.009005 ?
 223   eval <<'__QR__'
 224   qr{
 225     \s* : \s*
 226     (?:
 227         # one attribute
 228         (?> # no backtrack
 229             (?! \d) \w+
 230             (?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ?
 231         )
 232         (?: \s* : \s* | \s+ (?! :) )
 233     )*
 234   }x
 235 __QR__
 236   :
 237   do {
 238     # In pre-5.9.5 world we have to do dirty tricks.
 239     # (we use 'our' rather than 'my' here, due to the rather complex and buggy
 240     # behaviour of lexicals with qr// and (??{$lex}) )
 241     our $trick1; # yes, cannot our and assign at the same time.
 242     $trick1 = qr{ \( (?: (?> [^()]+ ) | (??{ $trick1 }) )* \) }x;
 243     our $trick2 = qr{ (?> (?! \d) \w+ (?:$trick1)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
 244     qr{ \s* : \s* (?: $trick2 )* }x;
 245   };
 246
 247 sub autosplit{
 248     my($file, $autodir,  $keep, $ckal, $ckmt) = @_;
 249     # $file    - the perl source file to be split (after __END__)
 250     # $autodir - the ".../auto" dir below which to write split subs
 251     # Handle optional flags:
 252     $keep = $Keep unless defined $keep;
 253     $ckal = $CheckForAutoloader unless defined $ckal;
 254     $ckmt = $CheckModTime unless defined $ckmt;
 255     autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
 256 }
 257
 258 sub carp{
 259     require Carp;
 260     goto &Carp::carp;
 261 }
 262
 263 # This function is used during perl building/installation
 264 # ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
 265
 266 sub autosplit_lib_modules {
 267     my(@modules) = @_; # list of Module names
 268     local $_; # Avoid clobber.
 269     while (defined($_ = shift @modules)) {
 270         while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ
 271             $_ = catfile($1, $2);
 272         }
 273         s|\\|/|g;               # bug in ksh OS/2
 274         s#^lib/##s; # incase specified as lib/*.pm
 275         my($lib) = catfile(curdir(), "lib");
 276         if ($Is_VMS) { # may need to convert VMS-style filespecs
 277             $lib =~ s#^\[\]#.\/#;
 278         }
 279         s#^$lib\W+##s; # incase specified as ./lib/*.pm
 280         if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
 281             my ($dir,$name) = (/(.*])(.*)/s);
 282             $dir =~ s/.*lib[\.\]]//s;
 283             $dir =~ s#[\.\]]#/#g;
 284             $_ = $dir . $name;
 285         }
 286         autosplit_file(catfile($lib, $_), catfile($lib, "auto"),
 287                        $Keep, $CheckForAutoloader, $CheckModTime);
 288     }
 289     0;
 290 }
 291
 292
 293 # private functions
 294
 295 my $self_mod_time = (stat __FILE__)[9];
 296
 297 sub autosplit_file {
 298     my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
 299         = @_;
 300     my(@outfiles);
 301     local($_);
 302     local($/) = "\n";
 303
 304     # where to write output files
 305     $autodir ||= catfile(curdir(), "lib", "auto");
 306     if ($Is_VMS) {
 307         ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||;
 308         $filename = VMS::Filespec::unixify($filename); # may have dirs
 309     }
 310     unless (-d $autodir){
 311         mkpath($autodir,0,0755);
 312         # We should never need to create the auto dir
 313         # here. installperl (or similar) should have done
 314         # it. Expecting it to exist is a valuable sanity check against
 315         # autosplitting into some random directory by mistake.
 316         print "Warning: AutoSplit had to create top-level " .
 317             "$autodir unexpectedly.\n";
 318     }
 319
 320     # allow just a package name to be used
 321     $filename .= ".pm" unless ($filename =~ m/\.pm\z/);
 322
 323     open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
 324     my($pm_mod_time) = (stat($filename))[9];
 325     my($autoloader_seen) = 0;
 326     my($in_pod) = 0;
 327     my($def_package,$last_package,$this_package,$fnr);
 328     while (<$in>) {
 329         # Skip pod text.
 330         $fnr++;
 331         $in_pod = 1 if /^=\w/;
 332         $in_pod = 0 if /^=cut/;
 333         next if ($in_pod || /^=cut/);
 334         next if /^\s*#/;
 335
 336         # record last package name seen
 337         $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
 338         ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
 339         ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
 340         last if /^__END__/;
 341     }
 342     if ($check_for_autoloader && !$autoloader_seen){
 343         print "AutoSplit skipped $filename: no AutoLoader used\n"
 344             if ($Verbose>=2);
 345         return 0;
 346     }
 347     $_ or die "Can't find __END__ in $filename\n";
 348
 349     $def_package or die "Can't find 'package Name;' in $filename\n";
 350
 351     my($modpname) = _modpname($def_package);
 352
 353     # this _has_ to match so we have a reasonable timestamp file
 354     die "Package $def_package ($modpname.pm) does not ".
 355         "match filename $filename"
 356             unless ($filename =~ m/\Q$modpname.pm\E$/ or
 357                     ($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or
 358                     $Is_VMS && $filename =~ m/$modpname.pm/i);
 359
 360     my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);
 361
 362     if ($check_mod_time){
 363         my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
 364         if ($al_ts_time >= $pm_mod_time and
 365             $al_ts_time >= $self_mod_time){
 366             print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
 367                 if ($Verbose >= 2);
 368             return undef;       # one undef, not a list
 369         }
 370     }
 371
 372     my($modnamedir) = catdir($autodir, $modpname);
 373     print "AutoSplitting $filename ($modnamedir)\n"
 374         if $Verbose;
 375
 376     unless (-d $modnamedir){
 377         mkpath($modnamedir,0,0777);
 378     }
 379
 380     # We must try to deal with some SVR3 systems with a limit of 14
 381     # characters for file names. Sadly we *cannot* simply truncate all
 382     # file names to 14 characters on these systems because we *must*
 383     # create filenames which exactly match the names used by AutoLoader.pm.
 384     # This is a problem because some systems silently truncate the file
 385     # names while others treat long file names as an error.
 386
 387     my $Is83 = $maxflen==11;  # plain, case INSENSITIVE dos filenames
 388
 389     my(@subnames, $subname, %proto, %package);
 390     my @cache = ();
 391     my $caching = 1;
 392     $last_package = '';
 393     my $out;
 394     while (<$in>) {
 395         $fnr++;
 396         $in_pod = 1 if /^=\w/;
 397         $in_pod = 0 if /^=cut/;
 398         next if ($in_pod || /^=cut/);
 399         # the following (tempting) old coding gives big troubles if a
 400         # cut is forgotten at EOF:
 401         # next if /^=\w/ .. /^=cut/;
 402         if (/^package\s+([\w:]+)\s*;/) {
 403             $this_package = $def_package = $1;
 404         }
 405
 406         if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
 407             print $out "# end of $last_package\::$subname\n1;\n"
 408                 if $last_package;
 409             $subname = $1;
 410             my $proto = $2 || '';
 411             if ($subname =~ s/(.*):://){
 412                 $this_package = $1;
 413             } else {
 414                 $this_package = $def_package;
 415             }
 416             my $fq_subname = "$this_package\::$subname";
 417             $package{$fq_subname} = $this_package;
 418             $proto{$fq_subname} = $proto;
 419             push(@subnames, $fq_subname);
 420             my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
 421             $modpname = _modpname($this_package);
 422             my($modnamedir) = catdir($autodir, $modpname);
 423             mkpath($modnamedir,0,0777);
 424             my($lpath) = catfile($modnamedir, "$lname.al");
 425             my($spath) = catfile($modnamedir, "$sname.al");
 426             my $path;
 427
 428             if (!$Is83 and open($out, ">$lpath")){
 429                 $path=$lpath;
 430                 print "  writing $lpath\n" if ($Verbose>=2);
 431             } else {
 432                 open($out, ">$spath") or die "Can't create $spath: $!\n";
 433                 $path=$spath;
 434                 print "  writing $spath (with truncated name)\n"
 435                         if ($Verbose>=1);
 436             }
 437             push(@outfiles, $path);
 438             my $lineno = $fnr - @cache;
 439             print $out <<EOT;
 440 # NOTE: Derived from $filename.
 441 # Changes made here will be lost when autosplit is run again.
 442 # See AutoSplit.pm.
 443 package $this_package;
 444
 445 #line $lineno "$filename (autosplit into $path)"
 446 EOT
 447             print $out @cache;
 448             @cache = ();
 449             $caching = 0;
 450         }
 451         if($caching) {
 452             push(@cache, $_) if @cache || /\S/;
 453         } else {
 454             print $out $_;
 455         }
 456         if(/^\}/) {
 457             if($caching) {
 458                 print $out @cache;
 459                 @cache = ();
 460             }
 461             print $out "\n";
 462             $caching = 1;
 463         }
 464         $last_package = $this_package if defined $this_package;
 465     }
 466     if ($subname) {
 467         print $out @cache,"1;\n# end of $last_package\::$subname\n";
 468         close($out);
 469     }
 470     close($in);
 471
 472     if (!$keep){  # don't keep any obsolete *.al files in the directory
 473         my(%outfiles);
 474         # @outfiles{@outfiles} = @outfiles;
 475         # perl downcases all filenames on VMS (which upcases all filenames) so
 476         # we'd better downcase the sub name list too, or subs with upper case
 477         # letters in them will get their .al files deleted right after they're
 478         # created. (The mixed case sub name won't match the all-lowercase
 479         # filename, and so be cleaned up as a scrap file)
 480         if ($Is_VMS or $Is83) {
 481             %outfiles = map {lc($_) => lc($_) } @outfiles;
 482         } else {
 483             @outfiles{@outfiles} = @outfiles;
 484         }
 485         my(%outdirs,@outdirs);
 486         for (@outfiles) {
 487             $outdirs{File::Basename::dirname($_)}||=1;
 488         }
 489         for my $dir (keys %outdirs) {
 490             opendir(my $outdir,$dir);
 491             foreach (sort readdir($outdir)){
 492                 next unless /\.al\z/;
 493                 my($file) = catfile($dir, $_);
 494                 $file = lc $file if $Is83 or $Is_VMS;
 495                 next if $outfiles{$file};
 496                 print "  deleting $file\n" if ($Verbose>=2);
 497                 my($deleted,$thistime);  # catch all versions on VMS
 498                 do { $deleted += ($thistime = unlink $file) } while ($thistime);
 499                 carp ("Unable to delete $file: $!") unless $deleted;
 500             }
 501             closedir($outdir);
 502         }
 503     }
 504
 505     open(my $ts,">$al_idx_file") or
 506         carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!");
 507     print $ts "# Index created by AutoSplit for $filename\n";
 508     print $ts "#    (file acts as timestamp)\n";
 509     $last_package = '';
 510     for my $fqs (@subnames) {
 511         my($subname) = $fqs;
 512         $subname =~ s/.*:://;
 513         print $ts "package $package{$fqs};\n"
 514             unless $last_package eq $package{$fqs};
 515         print $ts "sub $subname $proto{$fqs};\n";
 516         $last_package = $package{$fqs};
 517     }
 518     print $ts "1;\n";
 519     close($ts);
 520
 521     _check_unique($filename, $Maxlen, 1, @outfiles);
 522
 523     @outfiles;
 524 }
 525
 526 sub _modpname ($) {
 527     my($package) = @_;
 528     my $modpname = $package;
 529     if ($^O eq 'MSWin32') {
 530         $modpname =~ s#::#\\#g;
 531     } else {
 532         my @modpnames = ();
 533         while ($modpname =~ m#(.*?[^:])::([^:].*)#) {
 534                push @modpnames, $1;
 535                $modpname = $2;
 536          }
 537         $modpname = catfile(@modpnames, $modpname);
 538     }
 539     if ($Is_VMS) {
 540         $modpname = VMS::Filespec::unixify($modpname); # may have dirs
 541     }
 542     $modpname;
 543 }
 544
 545 sub _check_unique {
 546     my($filename, $maxlen, $warn, @outfiles) = @_;
 547     my(%notuniq) = ();
 548     my(%shorts)  = ();
 549     my(@toolong) = grep(
 550                         length(File::Basename::basename($_))
 551                         > $maxlen,
 552                         @outfiles
 553                        );
 554
 555     foreach (@toolong){
 556         my($dir) = File::Basename::dirname($_);
 557         my($file) = File::Basename::basename($_);
 558         my($trunc) = substr($file,0,$maxlen);
 559         $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
 560         $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
 561             "$shorts{$dir}{$trunc}, $file" : $file;
 562     }
 563     if (%notuniq && $warn){
 564         print "$filename: some names are not unique when " .
 565             "truncated to $maxlen characters:\n";
 566         foreach my $dir (sort keys %notuniq){
 567             print " directory $dir:\n";
 568             foreach my $trunc (sort keys %{$notuniq{$dir}}) {
 569                 print "  $shorts{$dir}{$trunc} truncate to $trunc\n";
 570             }
 571         }
 572     }
 573 }
 574
 575 1;
 576 __END__
 577
 578 # test functions so AutoSplit.pm can be applied to itself:
 579 sub test1 ($)   { "test 1\n"; }
 580 sub test2 ($$)  { "test 2\n"; }
 581 sub test3 ($$$) { "test 3\n"; }
 582 sub testtesttesttest4_1  { "test 4\n"; }
 583 sub testtesttesttest4_2  { "duplicate test 4\n"; }
 584 sub Just::Another::test5 { "another test 5\n"; }
 585 sub test6       { return join ":", __FILE__,__LINE__; }
 586 package Yet::Another::AutoSplit;
 587 sub testtesttesttest4_1 ($)  { "another test 4\n"; }
 588 sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
 589 package Yet::More::Attributes;
 590 sub test_a1 ($) : locked :locked { 1; }
 591 sub test_a2 : locked { 1; }