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