Commit | Line | Data |
a0d0e21e |
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); |
3edbfbe5 |
11 | @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); |
a0d0e21e |
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; |
3edbfbe5 |
17 | $CheckForAutoloader = 1; |
18 | $CheckModTime = 1; |
a0d0e21e |
19 | |
3edbfbe5 |
20 | $IndexFile = "autosplit.ix"; # file also serves as timestamp |
a0d0e21e |
21 | $maxflen = 255; |
22 | $maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; |
23 | $vms = ($Config{'osname'} eq 'VMS'); |
24 | |
3edbfbe5 |
25 | |
a0d0e21e |
26 | sub autosplit{ |
75f92628 |
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); |
a0d0e21e |
35 | } |
36 | |
37 | |
a0d0e21e |
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 | } |
3edbfbe5 |
53 | autosplit_file("lib/$_", "lib/auto", $Keep, $CheckForAutoloader, $CheckModTime); |
a0d0e21e |
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; |
3edbfbe5 |
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 | } |
a0d0e21e |
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*;/); |
3edbfbe5 |
89 | ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/; |
a0d0e21e |
90 | ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; |
3edbfbe5 |
91 | ++$autoloader_seen if m/^\s*sub\s+AUTOLOAD\b/; |
a0d0e21e |
92 | last if /^__END__/; |
93 | } |
3edbfbe5 |
94 | if ($check_for_autoloader && !$autoloader_seen){ |
95 | print "AutoSplit skipped $filename: no AutoLoader used\n" if ($Verbose>=2); |
96 | return 0 |
97 | } |
a0d0e21e |
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, $_); |
42793c05 |
126 | next if -d "@p/"; |
a0d0e21e |
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 | |