home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / utilities / cli / perl / !Perl / Lib / pm / autosplit < prev    next >
Encoding:
Text File  |  1995-02-08  |  7.4 KB  |  249 lines
  1. package AutoSplit;
  2.  
  3. require 5.000;
  4. require Exporter;
  5.  
  6. use Config;
  7. use Carp;
  8.  
  9. @ISA = qw(Exporter);
  10. @EXPORT = qw(&autosplit &autosplit_lib_modules);
  11. @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
  12.  
  13. # for portability warn about names longer than $maxlen
  14. $Maxlen  = 8;    # 8 for dos, 11 (14-".al") for SYSVR3
  15. $Verbose = 1;    # 0=none, 1=minimal, 2=list .al files
  16. $Keep    = 0;
  17. $CheckForAutoloader = 1;
  18. $CheckModTime = 1;
  19.  
  20. $IndexFile = "autosplit.ix";    # file also serves as timestamp
  21. $maxflen = 255;
  22. $maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
  23. $vms = ($Config{'osname'} eq 'VMS');
  24.  
  25.  
  26. sub autosplit{
  27.     my($file, $autodir,  $k, $ckal, $ckmt) = @_;
  28.     # $file    - the perl source file to be split (after __END__)
  29.     # $autodir - the ".../auto" dir below which to write split subs
  30.     # Handle optional flags:
  31.     $keep = $Keep unless defined $k;
  32.     $ckal = $CheckForAutoloader unless defined $ckal;
  33.     $ckmt = $CheckModTime unless defined $ckmt;
  34.     autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
  35. }
  36.  
  37.  
  38. # This function is used during perl building/installation
  39. # ./miniperl -e 'use AutoSplit; autosplit_modules(@ARGV)' ...
  40.  
  41. sub autosplit_lib_modules{
  42.     my(@modules) = @_; # list of Module names
  43.  
  44.     foreach(@modules){
  45.     s#::#/#g;    # incase specified as ABC::XYZ
  46.     s#^lib/##; # incase specified as lib/*.pm
  47.     if ($vms && /[:>\]]/) { # may need to convert VMS-style filespecs
  48.         my ($dir,$name) = (/(.*])(.*)/);
  49.         $dir =~ s/.*lib[\.\]]//;
  50.         $dir =~ s#[\.\]]#/#g;
  51.         $_ = $dir . $name;
  52.     }
  53.     autosplit_file("lib/$_", "lib/auto", $Keep, $CheckForAutoloader, $CheckModTime);
  54.     }
  55.     0;
  56. }
  57.  
  58.  
  59. # private functions
  60.  
  61. sub autosplit_file{
  62.     my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_;
  63.     my(@names);
  64.  
  65.     # where to write output files
  66.     $autodir = "lib/auto" unless $autodir;
  67.     unless (-d $autodir){
  68.     local($", @p)="/";
  69.     foreach(split(/\//,$autodir)){
  70.         push(@p, $_);
  71.         next if -d "@p/";
  72.         mkdir("@p",0755) or die "AutoSplit unable to mkdir @p: $!";
  73.     }
  74.     # We should never need to create the auto dir here. installperl
  75.     # (or similar) should have done it. Expecting it to exist is a valuable
  76.     # sanity check against autosplitting into some random directory by mistake.
  77.     print "Warning: AutoSplit had to create top-level $autodir unexpectedly.\n";
  78.     }
  79.  
  80.     # allow just a package name to be used
  81.     $filename .= ".pm" unless ($filename =~ m/\.pm$/);
  82.  
  83.     open(IN, "<$filename") || die "AutoSplit: Can't open $filename: $!\n";
  84.     my($pm_mod_time) = (stat($filename))[9];
  85.     my($autoloader_seen) = 0;
  86.     while (<IN>) {
  87.     # record last package name seen
  88.     $package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
  89.     ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
  90.     ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
  91.     ++$autoloader_seen if m/^\s*sub\s+AUTOLOAD\b/;
  92.     last if /^__END__/;
  93.     }
  94.     if ($check_for_autoloader && !$autoloader_seen){
  95.     print "AutoSplit skipped $filename: no AutoLoader used\n" if ($Verbose>=2);
  96.     return 0
  97.     }
  98.     $_ or die "Can't find __END__ in $filename\n";
  99.  
  100.     $package or die "Can't find 'package Name;' in $filename\n";
  101.  
  102.     my($modpname) = $package; $modpname =~ s#::#/#g;
  103.     my($al_idx_file) = "$autodir/$modpname/$IndexFile";
  104.  
  105.     die "Package $package does not match filename $filename"
  106.         unless ($filename =~ m/$modpname.pm$/ or
  107.                 $vms && $filename =~ m/$modpname.pm/i);
  108.  
  109.     if ($check_mod_time){
  110.     my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
  111.     if ($al_ts_time >= $pm_mod_time){
  112.         print "AutoSplit skipped ($al_idx_file newer that $filename)\n"
  113.         if ($Verbose >= 2);
  114.         return undef;    # one undef, not a list
  115.     }
  116.     }
  117.  
  118.     my($from) = ($Verbose>=2) ? "$filename => " : "";
  119.     print "AutoSplitting $package ($from$autodir/$modpname)\n"
  120.     if $Verbose;
  121.  
  122.     unless (-d "$autodir/$modpname"){
  123.     local($", @p)="/";
  124.     foreach(split(/\//,"$autodir/$modpname")){
  125.         push(@p, $_);
  126.         next if -d "@p/";
  127.         mkdir("@p",0777) or die "AutoSplit unable to mkdir @p: $!";
  128.     }
  129.     }
  130.  
  131.     # We must try to deal with some SVR3 systems with a limit of 14
  132.     # characters for file names. Sadly we *cannot* simply truncate all
  133.     # file names to 14 characters on these systems because we *must*
  134.     # create filenames which exactly match the names used by AutoLoader.pm.
  135.     # This is a problem because some systems silently truncate the file
  136.     # names while others treat long file names as an error.
  137.  
  138.     # We do not yet deal with multiple packages within one file.
  139.     # Ideally both of these styles should work.
  140.     #
  141.     #   package NAME;
  142.     #   __END__
  143.     #   sub AAA { ... }
  144.     #   package NAME::option1;
  145.     #   sub BBB { ... }
  146.     #   package NAME::option2;
  147.     #   sub BBB { ... }
  148.     #
  149.     #   package NAME;
  150.     #   __END__
  151.     #   sub AAA { ... }
  152.     #   sub NAME::option1::BBB { ... }
  153.     #   sub NAME::option2::BBB { ... }
  154.     #
  155.     # For now both of these produce warnings.
  156.  
  157.     open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning
  158.     my(@subnames);
  159.     while (<IN>) {
  160.     if (/^package ([\w:]+)\s*;/) {
  161.         warn "package $1; in AutoSplit section ignored. Not currently supported.";
  162.     }
  163.     if (/^sub ([\w:]+)/) {
  164.         print OUT "1;\n";
  165.         my($subname) = $1;
  166.         if ($subname =~ m/::/){
  167.         warn "subs with package names not currently supported in AutoSplit section";
  168.         }
  169.         push(@subnames, $subname);
  170.         my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
  171.         my($lpath) = "$autodir/$modpname/$lname.al";
  172.         my($spath) = "$autodir/$modpname/$sname.al";
  173.         unless(open(OUT, ">$lpath")){
  174.         open(OUT, ">$spath") or die "Can't create $spath: $!\n";
  175.         push(@names, $sname);
  176.         print "  writing $spath (with truncated name)\n"
  177.             if ($Verbose>=1);
  178.         }else{
  179.         push(@names, $lname);
  180.         print "  writing $lpath\n" if ($Verbose>=2);
  181.         }
  182.         print OUT "# NOTE: Derived from $filename.  ",
  183.             "Changes made here will be lost.\n";
  184.         print OUT "package $package;\n\n";
  185.     }
  186.     print OUT $_;
  187.     }
  188.     print OUT "1;\n";
  189.     close(OUT);
  190.     close(IN);
  191.  
  192.     if (!$keep){  # don't keep any obsolete *.al files in the directory
  193.     my(%names);
  194.     @names{@names} = @names;
  195.     opendir(OUTDIR,"$autodir/$modpname");
  196.     foreach(sort readdir(OUTDIR)){
  197.         next unless /\.al$/;
  198.         my($subname) = m/(.*)\.al$/;
  199.         next if $names{substr($subname,0,$maxflen-3)};
  200.         my($file) = "$autodir/$modpname/$_";
  201.         print "  deleting $file\n" if ($Verbose>=2);
  202.         unlink $file or carp "Unable to delete $file: $!";
  203.     }
  204.     closedir(OUTDIR);
  205.     }
  206.  
  207.     open(TS,">$al_idx_file") or
  208.     carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!";
  209.     print TS "# Index created by AutoSplit for $filename (file acts as timestamp)\n";
  210.     print TS map("sub $_ ;\n", @subnames);
  211.     close(TS);
  212.  
  213.     check_unique($package, $Maxlen, 1, @names);
  214.  
  215.     @names;
  216. }
  217.  
  218.  
  219. sub check_unique{
  220.     my($module, $maxlen, $warn, @names) = @_;
  221.     my(%notuniq) = ();
  222.     my(%shorts)  = ();
  223.     my(@toolong) = grep(length > $maxlen, @names);
  224.  
  225.     foreach(@toolong){
  226.     my($trunc) = substr($_,0,$maxlen);
  227.     $notuniq{$trunc}=1 if $shorts{$trunc};
  228.     $shorts{$trunc} = ($shorts{$trunc}) ? "$shorts{$trunc}, $_" : $_;
  229.     }
  230.     if (%notuniq && $warn){
  231.     print "$module: some names are not unique when truncated to $maxlen characters:\n";
  232.     foreach(keys %notuniq){
  233.         print " $shorts{$_} truncate to $_\n";
  234.     }
  235.     }
  236.     %notuniq;
  237. }
  238.  
  239. 1;
  240. __END__
  241.  
  242. # test functions so AutoSplit.pm can be applied to itself:
  243. sub test1{ "test 1\n"; }
  244. sub test2{ "test 2\n"; }
  245. sub test3{ "test 3\n"; }
  246. sub test4{ "test 4\n"; }
  247.  
  248.  
  249.