[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/ -> AutoSplit.pm (source)

   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  =cut
 132  
 133  # for portability warn about names longer than $maxlen
 134  $Maxlen  = 8;    # 8 for dos, 11 (14-".al") for SYSVR3
 135  $Verbose = 1;    # 0=none, 1=minimal, 2=list .al files
 136  $Keep    = 0;
 137  $CheckForAutoloader = 1;
 138  $CheckModTime = 1;
 139  
 140  my $IndexFile = "autosplit.ix";    # file also serves as timestamp
 141  my $maxflen = 255;
 142  $maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
 143  if (defined (&Dos::UseLFN)) {
 144       $maxflen = Dos::UseLFN() ? 255 : 11;
 145  }
 146  my $Is_VMS = ($^O eq 'VMS');
 147  
 148  # allow checking for valid ': attrlist' attachments.
 149  # extra jugglery required to support both 5.8 and 5.9/5.10 features
 150  # (support for 5.8 required for cross-compiling environments)
 151  
 152  my $attr_list = 
 153    $] >= 5.009005 ?
 154    eval <<'__QR__'
 155    qr{
 156      \s* : \s*
 157      (?:
 158      # one attribute
 159      (?> # no backtrack
 160          (?! \d) \w+
 161          (?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ?
 162      )
 163      (?: \s* : \s* | \s+ (?! :) )
 164      )*
 165    }x
 166  __QR__
 167    :
 168    do {
 169      # In pre-5.9.5 world we have to do dirty tricks.
 170      # (we use 'our' rather than 'my' here, due to the rather complex and buggy
 171      # behaviour of lexicals with qr// and (??{$lex}) )
 172      our $trick1; # yes, cannot our and assign at the same time.
 173      $trick1 = qr{ \( (?: (?> [^()]+ ) | (??{ $trick1 }) )* \) }x;
 174      our $trick2 = qr{ (?> (?! \d) \w+ (?:$trick1)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
 175      qr{ \s* : \s* (?: $trick2 )* }x;
 176    };
 177  
 178  sub autosplit{
 179      my($file, $autodir,  $keep, $ckal, $ckmt) = @_;
 180      # $file    - the perl source file to be split (after __END__)
 181      # $autodir - the ".../auto" dir below which to write split subs
 182      # Handle optional flags:
 183      $keep = $Keep unless defined $keep;
 184      $ckal = $CheckForAutoloader unless defined $ckal;
 185      $ckmt = $CheckModTime unless defined $ckmt;
 186      autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
 187  }
 188  
 189  sub carp{
 190      require Carp;
 191      goto &Carp::carp;
 192  }
 193  
 194  # This function is used during perl building/installation
 195  # ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
 196  
 197  sub autosplit_lib_modules {
 198      my(@modules) = @_; # list of Module names
 199      local $_; # Avoid clobber.
 200      while (defined($_ = shift @modules)) {
 201      while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ
 202          $_ = catfile($1, $2);
 203      }
 204      s|\\|/|g;        # bug in ksh OS/2
 205      s#^lib/##s; # incase specified as lib/*.pm
 206      my($lib) = catfile(curdir(), "lib");
 207      if ($Is_VMS) { # may need to convert VMS-style filespecs
 208          $lib =~ s#^\[\]#.\/#;
 209      }
 210      s#^$lib\W+##s; # incase specified as ./lib/*.pm
 211      if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
 212          my ($dir,$name) = (/(.*])(.*)/s);
 213          $dir =~ s/.*lib[\.\]]//s;
 214          $dir =~ s#[\.\]]#/#g;
 215          $_ = $dir . $name;
 216      }
 217      autosplit_file(catfile($lib, $_), catfile($lib, "auto"),
 218                 $Keep, $CheckForAutoloader, $CheckModTime);
 219      }
 220      0;
 221  }
 222  
 223  
 224  # private functions
 225  
 226  my $self_mod_time = (stat __FILE__)[9];
 227  
 228  sub autosplit_file {
 229      my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
 230      = @_;
 231      my(@outfiles);
 232      local($_);
 233      local($/) = "\n";
 234  
 235      # where to write output files
 236      $autodir ||= catfile(curdir(), "lib", "auto");
 237      if ($Is_VMS) {
 238      ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||;
 239      $filename = VMS::Filespec::unixify($filename); # may have dirs
 240      }
 241      unless (-d $autodir){
 242      mkpath($autodir,0,0755);
 243      # We should never need to create the auto dir
 244      # here. installperl (or similar) should have done
 245      # it. Expecting it to exist is a valuable sanity check against
 246      # autosplitting into some random directory by mistake.
 247      print "Warning: AutoSplit had to create top-level " .
 248          "$autodir unexpectedly.\n";
 249      }
 250  
 251      # allow just a package name to be used
 252      $filename .= ".pm" unless ($filename =~ m/\.pm\z/);
 253  
 254      open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
 255      my($pm_mod_time) = (stat($filename))[9];
 256      my($autoloader_seen) = 0;
 257      my($in_pod) = 0;
 258      my($def_package,$last_package,$this_package,$fnr);
 259      while (<$in>) {
 260      # Skip pod text.
 261      $fnr++;
 262      $in_pod = 1 if /^=\w/;
 263      $in_pod = 0 if /^=cut/;
 264      next if ($in_pod || /^=cut/);
 265          next if /^\s*#/;
 266  
 267      # record last package name seen
 268      $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
 269      ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
 270      ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
 271      last if /^__END__/;
 272      }
 273      if ($check_for_autoloader && !$autoloader_seen){
 274      print "AutoSplit skipped $filename: no AutoLoader used\n"
 275          if ($Verbose>=2);
 276      return 0;
 277      }
 278      $_ or die "Can't find __END__ in $filename\n";
 279  
 280      $def_package or die "Can't find 'package Name;' in $filename\n";
 281  
 282      my($modpname) = _modpname($def_package); 
 283  
 284      # this _has_ to match so we have a reasonable timestamp file
 285      die "Package $def_package ($modpname.pm) does not ".
 286      "match filename $filename"
 287          unless ($filename =~ m/\Q$modpname.pm\E$/ or
 288              ($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or
 289                  $Is_VMS && $filename =~ m/$modpname.pm/i);
 290  
 291      my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);
 292  
 293      if ($check_mod_time){
 294      my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
 295      if ($al_ts_time >= $pm_mod_time and
 296          $al_ts_time >= $self_mod_time){
 297          print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
 298          if ($Verbose >= 2);
 299          return undef;    # one undef, not a list
 300      }
 301      }
 302  
 303      my($modnamedir) = catdir($autodir, $modpname);
 304      print "AutoSplitting $filename ($modnamedir)\n"
 305      if $Verbose;
 306  
 307      unless (-d $modnamedir){
 308      mkpath($modnamedir,0,0777);
 309      }
 310  
 311      # We must try to deal with some SVR3 systems with a limit of 14
 312      # characters for file names. Sadly we *cannot* simply truncate all
 313      # file names to 14 characters on these systems because we *must*
 314      # create filenames which exactly match the names used by AutoLoader.pm.
 315      # This is a problem because some systems silently truncate the file
 316      # names while others treat long file names as an error.
 317  
 318      my $Is83 = $maxflen==11;  # plain, case INSENSITIVE dos filenames
 319  
 320      my(@subnames, $subname, %proto, %package);
 321      my @cache = ();
 322      my $caching = 1;
 323      $last_package = '';
 324      my $out;
 325      while (<$in>) {
 326      $fnr++;
 327      $in_pod = 1 if /^=\w/;
 328      $in_pod = 0 if /^=cut/;
 329      next if ($in_pod || /^=cut/);
 330      # the following (tempting) old coding gives big troubles if a
 331      # cut is forgotten at EOF:
 332      # next if /^=\w/ .. /^=cut/;
 333      if (/^package\s+([\w:]+)\s*;/) {
 334          $this_package = $def_package = $1;
 335      }
 336  
 337      if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
 338          print $out "# end of $last_package\::$subname\n1;\n"
 339          if $last_package;
 340          $subname = $1;
 341          my $proto = $2 || '';
 342          if ($subname =~ s/(.*):://){
 343          $this_package = $1;
 344          } else {
 345          $this_package = $def_package;
 346          }
 347          my $fq_subname = "$this_package\::$subname";
 348          $package{$fq_subname} = $this_package;
 349          $proto{$fq_subname} = $proto;
 350          push(@subnames, $fq_subname);
 351          my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
 352          $modpname = _modpname($this_package);
 353              my($modnamedir) = catdir($autodir, $modpname);
 354          mkpath($modnamedir,0,0777);
 355          my($lpath) = catfile($modnamedir, "$lname.al");
 356          my($spath) = catfile($modnamedir, "$sname.al");
 357          my $path;
 358  
 359          if (!$Is83 and open($out, ">$lpath")){
 360              $path=$lpath;
 361          print "  writing $lpath\n" if ($Verbose>=2);
 362          } else {
 363          open($out, ">$spath") or die "Can't create $spath: $!\n";
 364          $path=$spath;
 365          print "  writing $spath (with truncated name)\n"
 366              if ($Verbose>=1);
 367          }
 368          push(@outfiles, $path);
 369          my $lineno = $fnr - @cache;
 370          print $out <<EOT;
 371  # NOTE: Derived from $filename.
 372  # Changes made here will be lost when autosplit is run again.
 373  # See AutoSplit.pm.
 374  package $this_package;
 375  
 376  #line $lineno "$filename (autosplit into $path)"
 377  EOT
 378          print $out @cache;
 379          @cache = ();
 380          $caching = 0;
 381      }
 382      if($caching) {
 383          push(@cache, $_) if @cache || /\S/;
 384      } else {
 385          print $out $_;
 386      }
 387      if(/^\}/) {
 388          if($caching) {
 389          print $out @cache;
 390          @cache = ();
 391          }
 392          print $out "\n";
 393          $caching = 1;
 394      }
 395      $last_package = $this_package if defined $this_package;
 396      }
 397      if ($subname) {
 398      print $out @cache,"1;\n# end of $last_package\::$subname\n";
 399      close($out);
 400      }
 401      close($in);
 402      
 403      if (!$keep){  # don't keep any obsolete *.al files in the directory
 404      my(%outfiles);
 405      # @outfiles{@outfiles} = @outfiles;
 406      # perl downcases all filenames on VMS (which upcases all filenames) so
 407      # we'd better downcase the sub name list too, or subs with upper case
 408      # letters in them will get their .al files deleted right after they're
 409      # created. (The mixed case sub name won't match the all-lowercase
 410      # filename, and so be cleaned up as a scrap file)
 411      if ($Is_VMS or $Is83) {
 412          %outfiles = map {lc($_) => lc($_) } @outfiles;
 413      } else {
 414          @outfiles{@outfiles} = @outfiles;
 415      }  
 416      my(%outdirs,@outdirs);
 417      for (@outfiles) {
 418          $outdirs{File::Basename::dirname($_)}||=1;
 419      }
 420      for my $dir (keys %outdirs) {
 421          opendir(my $outdir,$dir);
 422          foreach (sort readdir($outdir)){
 423          next unless /\.al\z/;
 424          my($file) = catfile($dir, $_);
 425          $file = lc $file if $Is83 or $Is_VMS;
 426          next if $outfiles{$file};
 427          print "  deleting $file\n" if ($Verbose>=2);
 428          my($deleted,$thistime);  # catch all versions on VMS
 429          do { $deleted += ($thistime = unlink $file) } while ($thistime);
 430          carp ("Unable to delete $file: $!") unless $deleted;
 431          }
 432          closedir($outdir);
 433      }
 434      }
 435  
 436      open(my $ts,">$al_idx_file") or
 437      carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!");
 438      print $ts "# Index created by AutoSplit for $filename\n";
 439      print $ts "#    (file acts as timestamp)\n";
 440      $last_package = '';
 441      for my $fqs (@subnames) {
 442      my($subname) = $fqs;
 443      $subname =~ s/.*:://;
 444      print $ts "package $package{$fqs};\n"
 445          unless $last_package eq $package{$fqs};
 446      print $ts "sub $subname $proto{$fqs};\n";
 447      $last_package = $package{$fqs};
 448      }
 449      print $ts "1;\n";
 450      close($ts);
 451  
 452      _check_unique($filename, $Maxlen, 1, @outfiles);
 453  
 454      @outfiles;
 455  }
 456  
 457  sub _modpname ($) {
 458      my($package) = @_;
 459      my $modpname = $package;
 460      if ($^O eq 'MSWin32') {
 461      $modpname =~ s#::#\\#g; 
 462      } else {
 463      my @modpnames = ();
 464      while ($modpname =~ m#(.*?[^:])::([^:].*)#) {
 465             push @modpnames, $1;
 466             $modpname = $2;
 467           }
 468      $modpname = catfile(@modpnames, $modpname);
 469      }
 470      if ($Is_VMS) {
 471          $modpname = VMS::Filespec::unixify($modpname); # may have dirs
 472      }
 473      $modpname;
 474  }
 475  
 476  sub _check_unique {
 477      my($filename, $maxlen, $warn, @outfiles) = @_;
 478      my(%notuniq) = ();
 479      my(%shorts)  = ();
 480      my(@toolong) = grep(
 481              length(File::Basename::basename($_))
 482              > $maxlen,
 483              @outfiles
 484                 );
 485  
 486      foreach (@toolong){
 487      my($dir) = File::Basename::dirname($_);
 488      my($file) = File::Basename::basename($_);
 489      my($trunc) = substr($file,0,$maxlen);
 490      $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
 491      $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
 492          "$shorts{$dir}{$trunc}, $file" : $file;
 493      }
 494      if (%notuniq && $warn){
 495      print "$filename: some names are not unique when " .
 496          "truncated to $maxlen characters:\n";
 497      foreach my $dir (sort keys %notuniq){
 498          print " directory $dir:\n";
 499          foreach my $trunc (sort keys %{$notuniq{$dir}}) {
 500          print "  $shorts{$dir}{$trunc} truncate to $trunc\n";
 501          }
 502      }
 503      }
 504  }
 505  
 506  1;
 507  __END__
 508  
 509  # test functions so AutoSplit.pm can be applied to itself:
 510  sub test1 ($)   { "test 1\n"; }
 511  sub test2 ($$)  { "test 2\n"; }
 512  sub test3 ($$$) { "test 3\n"; }
 513  sub testtesttesttest4_1  { "test 4\n"; }
 514  sub testtesttesttest4_2  { "duplicate test 4\n"; }
 515  sub Just::Another::test5 { "another test 5\n"; }
 516  sub test6       { return join ":", __FILE__,__LINE__; }
 517  package Yet::Another::AutoSplit;
 518  sub testtesttesttest4_1 ($)  { "another test 4\n"; }
 519  sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
 520  package Yet::More::Attributes;
 521  sub test_a1 ($) : locked :locked { 1; }
 522  sub test_a2 : locked { 1; }


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1