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