This is my patch patch.0a for perl5.000.
[perl.git] / 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