diff options
Diffstat (limited to 'lib/AutoSplit.pm')
| -rw-r--r-- | lib/AutoSplit.pm | 225 |
1 files changed, 225 insertions, 0 deletions
diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm new file mode 100644 index 0000000000..dabf43cbb8 --- /dev/null +++ b/lib/AutoSplit.pm @@ -0,0 +1,225 @@ +package AutoSplit; + +require 5.000; +require Exporter; + +use Config; +use Carp; + +@ISA = qw(Exporter); +@EXPORT = qw(&autosplit &autosplit_lib_modules); +@EXPORT_OK = qw($Verbose $Keep); + +# for portability warn about names longer than $maxlen +$Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3 +$Verbose = 1; # 0=none, 1=minimal, 2=list .al files +$Keep = 0; +$IndexFile = "autosplit.ix"; # file also serves as timestamp + +$maxflen = 255; +$maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; +$vms = ($Config{'osname'} eq 'VMS'); + +sub autosplit{ + my($file, $autodir) = @_; + autosplit_file($file, $autodir, $Keep, 1, 0); +} + + + +# This function is used during perl building/installation +# ./miniperl -e 'use AutoSplit; autosplit_modules(@ARGV)' ... + +sub autosplit_lib_modules{ + my(@modules) = @_; # list of Module names + + foreach(@modules){ + s#::#/#g; # incase specified as ABC::XYZ + s#^lib/##; # incase specified as lib/*.pm + if ($vms && /[:>\]]/) { # may need to convert VMS-style filespecs + my ($dir,$name) = (/(.*])(.*)/); + $dir =~ s/.*lib[\.\]]//; + $dir =~ s#[\.\]]#/#g; + $_ = $dir . $name; + } + autosplit_file("lib/$_", "lib/auto", $Keep, 1, 1); + } + 0; +} + + +# private functions + +sub autosplit_file{ + my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_; + my(@names); + + # where to write output files + $autodir = "lib/auto" unless $autodir; + die "autosplit directory $autodir does not exist" unless -d $autodir; + + # allow just a package name to be used + $filename .= ".pm" unless ($filename =~ m/\.pm$/); + + open(IN, "<$filename") || die "AutoSplit: Can't open $filename: $!\n"; + my($pm_mod_time) = (stat($filename))[9]; + my($autoloader_seen) = 0; + while (<IN>) { + # record last package name seen + $package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); + ++$autoloader_seen if m/^\s*use\s+AutoLoader\b/; + ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; + last if /^__END__/; + } + return 0 if ($check_for_autoloader && !$autoloader_seen); + $_ or die "Can't find __END__ in $filename\n"; + + $package or die "Can't find 'package Name;' in $filename\n"; + + my($modpname) = $package; $modpname =~ s#::#/#g; + my($al_idx_file) = "$autodir/$modpname/$IndexFile"; + + die "Package $package does not match filename $filename" + unless ($filename =~ m/$modpname.pm$/ or + $vms && $filename =~ m/$modpname.pm/i); + + if ($check_mod_time){ + my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; + if ($al_ts_time >= $pm_mod_time){ + print "AutoSplit skipped ($al_idx_file newer that $filename)\n" + if ($Verbose >= 2); + return undef; # one undef, not a list + } + } + + my($from) = ($Verbose>=2) ? "$filename => " : ""; + print "AutoSplitting $package ($from$autodir/$modpname)\n" + if $Verbose; + + unless (-d "$autodir/$modpname"){ + local($", @p)="/"; + foreach(split(/\//,"$autodir/$modpname")){ + push(@p, $_); + next if -d "@p"; + mkdir("@p",0777) or die "AutoSplit unable to mkdir @p: $!"; + } + } + + # We must try to deal with some SVR3 systems with a limit of 14 + # characters for file names. Sadly we *cannot* simply truncate all + # file names to 14 characters on these systems because we *must* + # create filenames which exactly match the names used by AutoLoader.pm. + # This is a problem because some systems silently truncate the file + # names while others treat long file names as an error. + + # We do not yet deal with multiple packages within one file. + # Ideally both of these styles should work. + # + # package NAME; + # __END__ + # sub AAA { ... } + # package NAME::option1; + # sub BBB { ... } + # package NAME::option2; + # sub BBB { ... } + # + # package NAME; + # __END__ + # sub AAA { ... } + # sub NAME::option1::BBB { ... } + # sub NAME::option2::BBB { ... } + # + # For now both of these produce warnings. + + open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning + my(@subnames); + while (<IN>) { + if (/^package ([\w:]+)\s*;/) { + warn "package $1; in AutoSplit section ignored. Not currently supported."; + } + if (/^sub ([\w:]+)/) { + print OUT "1;\n"; + my($subname) = $1; + if ($subname =~ m/::/){ + warn "subs with package names not currently supported in AutoSplit section"; + } + push(@subnames, $subname); + my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); + my($lpath) = "$autodir/$modpname/$lname.al"; + my($spath) = "$autodir/$modpname/$sname.al"; + unless(open(OUT, ">$lpath")){ + open(OUT, ">$spath") or die "Can't create $spath: $!\n"; + push(@names, $sname); + print " writing $spath (with truncated name)\n" + if ($Verbose>=1); + }else{ + push(@names, $lname); + print " writing $lpath\n" if ($Verbose>=2); + } + print OUT "# NOTE: Derived from $filename. ", + "Changes made here will be lost.\n"; + print OUT "package $package;\n\n"; + } + print OUT $_; + } + print OUT "1;\n"; + close(OUT); + close(IN); + + if (!$keep){ # don't keep any obsolete *.al files in the directory + my(%names); + @names{@names} = @names; + opendir(OUTDIR,"$autodir/$modpname"); + foreach(sort readdir(OUTDIR)){ + next unless /\.al$/; + my($subname) = m/(.*)\.al$/; + next if $names{substr($subname,0,$maxflen-3)}; + my($file) = "$autodir/$modpname/$_"; + print " deleting $file\n" if ($Verbose>=2); + unlink $file or carp "Unable to delete $file: $!"; + } + closedir(OUTDIR); + } + + open(TS,">$al_idx_file") or + carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!"; + print TS "# Index created by AutoSplit for $filename (file acts as timestamp)\n"; + print TS map("sub $_ ;\n", @subnames); + close(TS); + + check_unique($package, $Maxlen, 1, @names); + + @names; +} + + +sub check_unique{ + my($module, $maxlen, $warn, @names) = @_; + my(%notuniq) = (); + my(%shorts) = (); + my(@toolong) = grep(length > $maxlen, @names); + + foreach(@toolong){ + my($trunc) = substr($_,0,$maxlen); + $notuniq{$trunc}=1 if $shorts{$trunc}; + $shorts{$trunc} = ($shorts{$trunc}) ? "$shorts{$trunc}, $_" : $_; + } + if (%notuniq && $warn){ + print "$module: some names are not unique when truncated to $maxlen characters:\n"; + foreach(keys %notuniq){ + print " $shorts{$_} truncate to $_\n"; + } + } + %notuniq; +} + +1; +__END__ + +# test functions so AutoSplit.pm can be applied to itself: +sub test1{ "test 1\n"; } +sub test2{ "test 2\n"; } +sub test3{ "test 3\n"; } +sub test4{ "test 4\n"; } + + |