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