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