lib/AutoSplit.pm

   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