Commit | Line | Data |
a0d0e21e |
1 | package AutoSplit; |
2 | |
4e6ea2c3 |
3 | use Exporter (); |
4 | use Config qw(%Config); |
4e6ea2c3 |
5 | use File::Basename (); |
68dc0745 |
6 | use File::Path qw(mkpath); |
64a3d80f |
7 | use File::Spec::Functions qw(curdir catfile catdir); |
4e6ea2c3 |
8 | use strict; |
17f410f9 |
9 | our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen, |
10 | $CheckForAutoloader, $CheckModTime); |
a0d0e21e |
11 | |
9938a85f |
12 | $VERSION = "1.05"; |
a0d0e21e |
13 | @ISA = qw(Exporter); |
14 | @EXPORT = qw(&autosplit &autosplit_lib_modules); |
3edbfbe5 |
15 | @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); |
a0d0e21e |
16 | |
f06db76b |
17 | =head1 NAME |
18 | |
19 | AutoSplit - split a package for autoloading |
20 | |
cb1a09d0 |
21 | =head1 SYNOPSIS |
22 | |
4e6ea2c3 |
23 | autosplit($file, $dir, $keep, $check, $modtime); |
84dc3c4d |
24 | |
4e6ea2c3 |
25 | autosplit_lib_modules(@modules); |
cb1a09d0 |
26 | |
f06db76b |
27 | =head1 DESCRIPTION |
28 | |
29 | This function will split up your program into files that the AutoLoader |
21c92a1d |
30 | module can handle. It is used by both the standard perl libraries and by |
31 | the MakeMaker utility, to automatically configure libraries for autoloading. |
32 | |
33 | The C<autosplit> interface splits the specified file into a hierarchy |
34 | rooted at the directory C<$dir>. It creates directories as needed to reflect |
35 | class hierarchy, and creates the file F<autosplit.ix>. This file acts as |
36 | both forward declaration of all package routines, and as timestamp for the |
37 | last update of the hierarchy. |
38 | |
4e6ea2c3 |
39 | The remaining three arguments to C<autosplit> govern other options to |
40 | the autosplitter. |
41 | |
42 | =over 2 |
43 | |
44 | =item $keep |
45 | |
46 | If the third argument, I<$keep>, is false, then any |
47 | pre-existing C<*.al> files in the autoload directory are removed if |
48 | they are no longer part of the module (obsoleted functions). |
49 | $keep defaults to 0. |
50 | |
51 | =item $check |
52 | |
53 | The |
54 | fourth argument, I<$check>, instructs C<autosplit> to check the module |
e8fac187 |
55 | currently being split to ensure that it includes a C<use> |
4e6ea2c3 |
56 | specification for the AutoLoader module, and skips the module if |
57 | AutoLoader is not detected. |
58 | $check defaults to 1. |
59 | |
60 | =item $modtime |
61 | |
62 | Lastly, the I<$modtime> argument specifies |
63 | that C<autosplit> is to check the modification time of the module |
64 | against that of the C<autosplit.ix> file, and only split the module if |
65 | it is newer. |
66 | $modtime defaults to 1. |
67 | |
68 | =back |
21c92a1d |
69 | |
70 | Typical use of AutoSplit in the perl MakeMaker utility is via the command-line |
71 | with: |
72 | |
73 | perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)' |
74 | |
75 | Defined as a Make macro, it is invoked with file and directory arguments; |
76 | C<autosplit> will split the specified file into the specified directory and |
77 | delete obsolete C<.al> files, after checking first that the module does use |
78 | the AutoLoader, and ensuring that the module is not already currently split |
79 | in its current form (the modtime test). |
80 | |
81 | The C<autosplit_lib_modules> form is used in the building of perl. It takes |
82 | as input a list of files (modules) that are assumed to reside in a directory |
83 | B<lib> relative to the current directory. Each file is sent to the |
84 | autosplitter one at a time, to be split into the directory B<lib/auto>. |
85 | |
86 | In both usages of the autosplitter, only subroutines defined following the |
4e6ea2c3 |
87 | perl I<__END__> token are split out into separate files. Some |
21c92a1d |
88 | routines may be placed prior to this marker to force their immediate loading |
89 | and parsing. |
90 | |
4e6ea2c3 |
91 | =head2 Multiple packages |
92 | |
93 | As of version 1.01 of the AutoSplit module it is possible to have |
94 | multiple packages within a single file. Both of the following cases |
95 | are supported: |
96 | |
97 | package NAME; |
98 | __END__ |
99 | sub AAA { ... } |
100 | package NAME::option1; |
101 | sub BBB { ... } |
102 | package NAME::option2; |
103 | sub BBB { ... } |
21c92a1d |
104 | |
4e6ea2c3 |
105 | package NAME; |
106 | __END__ |
107 | sub AAA { ... } |
108 | sub NAME::option1::BBB { ... } |
109 | sub NAME::option2::BBB { ... } |
21c92a1d |
110 | |
111 | =head1 DIAGNOSTICS |
112 | |
4e6ea2c3 |
113 | C<AutoSplit> will inform the user if it is necessary to create the |
114 | top-level directory specified in the invocation. It is preferred that |
115 | the script or installation process that invokes C<AutoSplit> have |
116 | created the full directory path ahead of time. This warning may |
117 | indicate that the module is being split into an incorrect path. |
21c92a1d |
118 | |
4e6ea2c3 |
119 | C<AutoSplit> will warn the user of all subroutines whose name causes |
120 | potential file naming conflicts on machines with drastically limited |
121 | (8 characters or less) file name length. Since the subroutine name is |
122 | used as the file name, these warnings can aid in portability to such |
123 | systems. |
21c92a1d |
124 | |
4e6ea2c3 |
125 | Warnings are issued and the file skipped if C<AutoSplit> cannot locate |
126 | either the I<__END__> marker or a "package Name;"-style specification. |
21c92a1d |
127 | |
4e6ea2c3 |
128 | C<AutoSplit> will also emit general diagnostics for inability to |
129 | create directories or files. |
f06db76b |
130 | |
131 | =cut |
132 | |
a0d0e21e |
133 | # for portability warn about names longer than $maxlen |
134 | $Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3 |
135 | $Verbose = 1; # 0=none, 1=minimal, 2=list .al files |
136 | $Keep = 0; |
3edbfbe5 |
137 | $CheckForAutoloader = 1; |
138 | $CheckModTime = 1; |
a0d0e21e |
139 | |
4e6ea2c3 |
140 | my $IndexFile = "autosplit.ix"; # file also serves as timestamp |
141 | my $maxflen = 255; |
a0d0e21e |
142 | $maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; |
39e571d4 |
143 | if (defined (&Dos::UseLFN)) { |
144 | $maxflen = Dos::UseLFN() ? 255 : 11; |
145 | } |
4e6ea2c3 |
146 | my $Is_VMS = ($^O eq 'VMS'); |
a0d0e21e |
147 | |
4764e399 |
148 | # allow checking for valid ': attrlist' attachments. |
149 | # extra jugglery required to support both 5.8 and 5.9/5.10 features |
150 | # (support for 5.8 required for cross-compiling environments) |
09bef843 |
151 | |
4764e399 |
152 | my $attr_list = |
153 | $] >= 5.009005 ? |
154 | eval <<'__QR__' |
155 | qr{ |
91798d18 |
156 | \s* : \s* |
157 | (?: |
158 | # one attribute |
159 | (?> # no backtrack |
160 | (?! \d) \w+ |
161 | (?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ? |
162 | ) |
163 | (?: \s* : \s* | \s+ (?! :) ) |
164 | )* |
4764e399 |
165 | }x |
166 | __QR__ |
167 | : |
168 | do { |
169 | # In pre-5.9.5 world we have to do dirty tricks. |
170 | # (we use 'our' rather than 'my' here, due to the rather complex and buggy |
171 | # behaviour of lexicals with qr// and (??{$lex}) ) |
172 | our $trick1; # yes, cannot our and assign at the same time. |
173 | $trick1 = qr{ \( (?: (?> [^()]+ ) | (??{ $trick1 }) )* \) }x; |
174 | our $trick2 = qr{ (?> (?! \d) \w+ (?:$trick1)? ) (?:\s*\:\s*|\s+(?!\:)) }x; |
175 | qr{ \s* : \s* (?: $trick2 )* }x; |
176 | }; |
3edbfbe5 |
177 | |
a0d0e21e |
178 | sub autosplit{ |
4e6ea2c3 |
179 | my($file, $autodir, $keep, $ckal, $ckmt) = @_; |
75f92628 |
180 | # $file - the perl source file to be split (after __END__) |
181 | # $autodir - the ".../auto" dir below which to write split subs |
182 | # Handle optional flags: |
4e6ea2c3 |
183 | $keep = $Keep unless defined $keep; |
75f92628 |
184 | $ckal = $CheckForAutoloader unless defined $ckal; |
185 | $ckmt = $CheckModTime unless defined $ckmt; |
186 | autosplit_file($file, $autodir, $keep, $ckal, $ckmt); |
a0d0e21e |
187 | } |
188 | |
8878f897 |
189 | sub carp{ |
190 | require Carp; |
191 | goto &Carp::carp; |
192 | } |
a0d0e21e |
193 | |
a0d0e21e |
194 | # This function is used during perl building/installation |
21c92a1d |
195 | # ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ... |
a0d0e21e |
196 | |
9938a85f |
197 | sub autosplit_lib_modules { |
a0d0e21e |
198 | my(@modules) = @_; # list of Module names |
4764e399 |
199 | local $_; # Avoid clobber. |
200 | while (defined($_ = shift @modules)) { |
9938a85f |
201 | while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ |
0eb04855 |
202 | $_ = catfile($1, $2); |
203 | } |
4633a7c4 |
204 | s|\\|/|g; # bug in ksh OS/2 |
413e5597 |
205 | s#^lib/##s; # incase specified as lib/*.pm |
0eb04855 |
206 | my($lib) = catfile(curdir(), "lib"); |
b1179839 |
207 | if ($Is_VMS) { # may need to convert VMS-style filespecs |
208 | $lib =~ s#^\[\]#.\/#; |
209 | } |
413e5597 |
210 | s#^$lib\W+##s; # incase specified as ./lib/*.pm |
c6538b72 |
211 | if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs |
14a089c5 |
212 | my ($dir,$name) = (/(.*])(.*)/s); |
213 | $dir =~ s/.*lib[\.\]]//s; |
a0d0e21e |
214 | $dir =~ s#[\.\]]#/#g; |
215 | $_ = $dir . $name; |
216 | } |
0eb04855 |
217 | autosplit_file(catfile($lib, $_), catfile($lib, "auto"), |
4e6ea2c3 |
218 | $Keep, $CheckForAutoloader, $CheckModTime); |
a0d0e21e |
219 | } |
220 | 0; |
221 | } |
222 | |
223 | |
224 | # private functions |
225 | |
e8fac187 |
226 | my $self_mod_time = (stat __FILE__)[9]; |
227 | |
4e6ea2c3 |
228 | sub autosplit_file { |
229 | my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) |
230 | = @_; |
231 | my(@outfiles); |
6e7678af |
232 | local($_); |
4e6ea2c3 |
233 | local($/) = "\n"; |
a0d0e21e |
234 | |
235 | # where to write output files |
0eb04855 |
236 | $autodir ||= catfile(curdir(), "lib", "auto"); |
f86702cc |
237 | if ($Is_VMS) { |
14a089c5 |
238 | ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||; |
f86702cc |
239 | $filename = VMS::Filespec::unixify($filename); # may have dirs |
240 | } |
3edbfbe5 |
241 | unless (-d $autodir){ |
68dc0745 |
242 | mkpath($autodir,0,0755); |
4e6ea2c3 |
243 | # We should never need to create the auto dir |
244 | # here. installperl (or similar) should have done |
245 | # it. Expecting it to exist is a valuable sanity check against |
246 | # autosplitting into some random directory by mistake. |
247 | print "Warning: AutoSplit had to create top-level " . |
248 | "$autodir unexpectedly.\n"; |
3edbfbe5 |
249 | } |
a0d0e21e |
250 | |
251 | # allow just a package name to be used |
14a089c5 |
252 | $filename .= ".pm" unless ($filename =~ m/\.pm\z/); |
a0d0e21e |
253 | |
b6c146dd |
254 | open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n"; |
a0d0e21e |
255 | my($pm_mod_time) = (stat($filename))[9]; |
256 | my($autoloader_seen) = 0; |
f06db76b |
257 | my($in_pod) = 0; |
4e6ea2c3 |
258 | my($def_package,$last_package,$this_package,$fnr); |
b6c146dd |
259 | while (<$in>) { |
f06db76b |
260 | # Skip pod text. |
4e6ea2c3 |
261 | $fnr++; |
697fd008 |
262 | $in_pod = 1 if /^=\w/; |
f06db76b |
263 | $in_pod = 0 if /^=cut/; |
264 | next if ($in_pod || /^=cut/); |
fe169e07 |
265 | next if /^\s*#/; |
f06db76b |
266 | |
a0d0e21e |
267 | # record last package name seen |
4e6ea2c3 |
268 | $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); |
3edbfbe5 |
269 | ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/; |
a0d0e21e |
270 | ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; |
271 | last if /^__END__/; |
272 | } |
3edbfbe5 |
273 | if ($check_for_autoloader && !$autoloader_seen){ |
4e6ea2c3 |
274 | print "AutoSplit skipped $filename: no AutoLoader used\n" |
275 | if ($Verbose>=2); |
276 | return 0; |
3edbfbe5 |
277 | } |
a0d0e21e |
278 | $_ or die "Can't find __END__ in $filename\n"; |
279 | |
4e6ea2c3 |
280 | $def_package or die "Can't find 'package Name;' in $filename\n"; |
a0d0e21e |
281 | |
4e6ea2c3 |
282 | my($modpname) = _modpname($def_package); |
a0d0e21e |
283 | |
4e6ea2c3 |
284 | # this _has_ to match so we have a reasonable timestamp file |
285 | die "Package $def_package ($modpname.pm) does not ". |
286 | "match filename $filename" |
68dc0745 |
287 | unless ($filename =~ m/\Q$modpname.pm\E$/ or |
2986a63f |
288 | ($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or |
c6538b72 |
289 | $Is_VMS && $filename =~ m/$modpname.pm/i); |
a0d0e21e |
290 | |
084592ab |
291 | my($al_idx_file) = catfile($autodir, $modpname, $IndexFile); |
68dc0745 |
292 | |
a0d0e21e |
293 | if ($check_mod_time){ |
294 | my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; |
e8fac187 |
295 | if ($al_ts_time >= $pm_mod_time and |
296 | $al_ts_time >= $self_mod_time){ |
4e6ea2c3 |
297 | print "AutoSplit skipped ($al_idx_file newer than $filename)\n" |
a0d0e21e |
298 | if ($Verbose >= 2); |
299 | return undef; # one undef, not a list |
300 | } |
301 | } |
302 | |
64a3d80f |
303 | my($modnamedir) = catdir($autodir, $modpname); |
0eb04855 |
304 | print "AutoSplitting $filename ($modnamedir)\n" |
a0d0e21e |
305 | if $Verbose; |
306 | |
084592ab |
307 | unless (-d $modnamedir){ |
308 | mkpath($modnamedir,0,0777); |
a0d0e21e |
309 | } |
310 | |
311 | # We must try to deal with some SVR3 systems with a limit of 14 |
312 | # characters for file names. Sadly we *cannot* simply truncate all |
313 | # file names to 14 characters on these systems because we *must* |
314 | # create filenames which exactly match the names used by AutoLoader.pm. |
315 | # This is a problem because some systems silently truncate the file |
316 | # names while others treat long file names as an error. |
317 | |
39e571d4 |
318 | my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames |
319 | |
4e6ea2c3 |
320 | my(@subnames, $subname, %proto, %package); |
96bc026d |
321 | my @cache = (); |
322 | my $caching = 1; |
4e6ea2c3 |
323 | $last_package = ''; |
b6c146dd |
324 | my $out; |
325 | while (<$in>) { |
4e6ea2c3 |
326 | $fnr++; |
53667d02 |
327 | $in_pod = 1 if /^=\w/; |
4e6ea2c3 |
328 | $in_pod = 0 if /^=cut/; |
329 | next if ($in_pod || /^=cut/); |
330 | # the following (tempting) old coding gives big troubles if a |
331 | # cut is forgotten at EOF: |
332 | # next if /^=\w/ .. /^=cut/; |
333 | if (/^package\s+([\w:]+)\s*;/) { |
334 | $this_package = $def_package = $1; |
a0d0e21e |
335 | } |
b6c146dd |
336 | |
09bef843 |
337 | if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) { |
b6c146dd |
338 | print $out "# end of $last_package\::$subname\n1;\n" |
4e6ea2c3 |
339 | if $last_package; |
340 | $subname = $1; |
341 | my $proto = $2 || ''; |
342 | if ($subname =~ s/(.*):://){ |
343 | $this_package = $1; |
344 | } else { |
345 | $this_package = $def_package; |
a0d0e21e |
346 | } |
4e6ea2c3 |
347 | my $fq_subname = "$this_package\::$subname"; |
348 | $package{$fq_subname} = $this_package; |
349 | $proto{$fq_subname} = $proto; |
350 | push(@subnames, $fq_subname); |
a0d0e21e |
351 | my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); |
4e6ea2c3 |
352 | $modpname = _modpname($this_package); |
64a3d80f |
353 | my($modnamedir) = catdir($autodir, $modpname); |
084592ab |
354 | mkpath($modnamedir,0,0777); |
0eb04855 |
355 | my($lpath) = catfile($modnamedir, "$lname.al"); |
356 | my($spath) = catfile($modnamedir, "$sname.al"); |
4e6ea2c3 |
357 | my $path; |
b6c146dd |
358 | |
359 | if (!$Is83 and open($out, ">$lpath")){ |
4e6ea2c3 |
360 | $path=$lpath; |
a0d0e21e |
361 | print " writing $lpath\n" if ($Verbose>=2); |
4e6ea2c3 |
362 | } else { |
b6c146dd |
363 | open($out, ">$spath") or die "Can't create $spath: $!\n"; |
4e6ea2c3 |
364 | $path=$spath; |
365 | print " writing $spath (with truncated name)\n" |
366 | if ($Verbose>=1); |
a0d0e21e |
367 | } |
4e6ea2c3 |
368 | push(@outfiles, $path); |
e8fac187 |
369 | my $lineno = $fnr - @cache; |
b6c146dd |
370 | print $out <<EOT; |
4e6ea2c3 |
371 | # NOTE: Derived from $filename. |
e8fac187 |
372 | # Changes made here will be lost when autosplit is run again. |
4e6ea2c3 |
373 | # See AutoSplit.pm. |
374 | package $this_package; |
375 | |
e8fac187 |
376 | #line $lineno "$filename (autosplit into $path)" |
4e6ea2c3 |
377 | EOT |
b6c146dd |
378 | print $out @cache; |
96bc026d |
379 | @cache = (); |
380 | $caching = 0; |
381 | } |
382 | if($caching) { |
383 | push(@cache, $_) if @cache || /\S/; |
4e6ea2c3 |
384 | } else { |
b6c146dd |
385 | print $out $_; |
96bc026d |
386 | } |
4e6ea2c3 |
387 | if(/^\}/) { |
96bc026d |
388 | if($caching) { |
b6c146dd |
389 | print $out @cache; |
96bc026d |
390 | @cache = (); |
391 | } |
b6c146dd |
392 | print $out "\n"; |
96bc026d |
393 | $caching = 1; |
a0d0e21e |
394 | } |
4e6ea2c3 |
395 | $last_package = $this_package if defined $this_package; |
a0d0e21e |
396 | } |
548da3d2 |
397 | if ($subname) { |
b6c146dd |
398 | print $out @cache,"1;\n# end of $last_package\::$subname\n"; |
399 | close($out); |
548da3d2 |
400 | } |
b6c146dd |
401 | close($in); |
4e6ea2c3 |
402 | |
a0d0e21e |
403 | if (!$keep){ # don't keep any obsolete *.al files in the directory |
4e6ea2c3 |
404 | my(%outfiles); |
405 | # @outfiles{@outfiles} = @outfiles; |
406 | # perl downcases all filenames on VMS (which upcases all filenames) so |
407 | # we'd better downcase the sub name list too, or subs with upper case |
408 | # letters in them will get their .al files deleted right after they're |
8f8c40b1 |
409 | # created. (The mixed case sub name won't match the all-lowercase |
4e6ea2c3 |
410 | # filename, and so be cleaned up as a scrap file) |
411 | if ($Is_VMS or $Is83) { |
412 | %outfiles = map {lc($_) => lc($_) } @outfiles; |
413 | } else { |
414 | @outfiles{@outfiles} = @outfiles; |
415 | } |
416 | my(%outdirs,@outdirs); |
417 | for (@outfiles) { |
418 | $outdirs{File::Basename::dirname($_)}||=1; |
419 | } |
420 | for my $dir (keys %outdirs) { |
b6c146dd |
421 | opendir(my $outdir,$dir); |
422 | foreach (sort readdir($outdir)){ |
14a089c5 |
423 | next unless /\.al\z/; |
0eb04855 |
424 | my($file) = catfile($dir, $_); |
8f8c40b1 |
425 | $file = lc $file if $Is83 or $Is_VMS; |
4e6ea2c3 |
426 | next if $outfiles{$file}; |
427 | print " deleting $file\n" if ($Verbose>=2); |
428 | my($deleted,$thistime); # catch all versions on VMS |
429 | do { $deleted += ($thistime = unlink $file) } while ($thistime); |
8878f897 |
430 | carp ("Unable to delete $file: $!") unless $deleted; |
4e6ea2c3 |
431 | } |
b6c146dd |
432 | closedir($outdir); |
a0d0e21e |
433 | } |
a0d0e21e |
434 | } |
435 | |
b6c146dd |
436 | open(my $ts,">$al_idx_file") or |
8878f897 |
437 | carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!"); |
b6c146dd |
438 | print $ts "# Index created by AutoSplit for $filename\n"; |
439 | print $ts "# (file acts as timestamp)\n"; |
4e6ea2c3 |
440 | $last_package = ''; |
441 | for my $fqs (@subnames) { |
442 | my($subname) = $fqs; |
443 | $subname =~ s/.*:://; |
b6c146dd |
444 | print $ts "package $package{$fqs};\n" |
4e6ea2c3 |
445 | unless $last_package eq $package{$fqs}; |
b6c146dd |
446 | print $ts "sub $subname $proto{$fqs};\n"; |
4e6ea2c3 |
447 | $last_package = $package{$fqs}; |
448 | } |
b6c146dd |
449 | print $ts "1;\n"; |
450 | close($ts); |
a0d0e21e |
451 | |
4e6ea2c3 |
452 | _check_unique($filename, $Maxlen, 1, @outfiles); |
a0d0e21e |
453 | |
4e6ea2c3 |
454 | @outfiles; |
a0d0e21e |
455 | } |
456 | |
4e6ea2c3 |
457 | sub _modpname ($) { |
458 | my($package) = @_; |
459 | my $modpname = $package; |
460 | if ($^O eq 'MSWin32') { |
461 | $modpname =~ s#::#\\#g; |
462 | } else { |
64a3d80f |
463 | my @modpnames = (); |
464 | while ($modpname =~ m#(.*?[^:])::([^:].*)#) { |
465 | push @modpnames, $1; |
466 | $modpname = $2; |
467 | } |
468 | $modpname = catfile(@modpnames, $modpname); |
469 | } |
470 | if ($Is_VMS) { |
471 | $modpname = VMS::Filespec::unixify($modpname); # may have dirs |
4e6ea2c3 |
472 | } |
473 | $modpname; |
474 | } |
a0d0e21e |
475 | |
4e6ea2c3 |
476 | sub _check_unique { |
477 | my($filename, $maxlen, $warn, @outfiles) = @_; |
a0d0e21e |
478 | my(%notuniq) = (); |
479 | my(%shorts) = (); |
4e6ea2c3 |
480 | my(@toolong) = grep( |
481 | length(File::Basename::basename($_)) |
482 | > $maxlen, |
483 | @outfiles |
484 | ); |
485 | |
486 | foreach (@toolong){ |
487 | my($dir) = File::Basename::dirname($_); |
488 | my($file) = File::Basename::basename($_); |
489 | my($trunc) = substr($file,0,$maxlen); |
490 | $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc}; |
491 | $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ? |
492 | "$shorts{$dir}{$trunc}, $file" : $file; |
a0d0e21e |
493 | } |
494 | if (%notuniq && $warn){ |
4e6ea2c3 |
495 | print "$filename: some names are not unique when " . |
496 | "truncated to $maxlen characters:\n"; |
497 | foreach my $dir (sort keys %notuniq){ |
498 | print " directory $dir:\n"; |
499 | foreach my $trunc (sort keys %{$notuniq{$dir}}) { |
500 | print " $shorts{$dir}{$trunc} truncate to $trunc\n"; |
501 | } |
a0d0e21e |
502 | } |
503 | } |
a0d0e21e |
504 | } |
505 | |
506 | 1; |
507 | __END__ |
508 | |
509 | # test functions so AutoSplit.pm can be applied to itself: |
4e6ea2c3 |
510 | sub test1 ($) { "test 1\n"; } |
511 | sub test2 ($$) { "test 2\n"; } |
512 | sub test3 ($$$) { "test 3\n"; } |
513 | sub testtesttesttest4_1 { "test 4\n"; } |
514 | sub testtesttesttest4_2 { "duplicate test 4\n"; } |
515 | sub Just::Another::test5 { "another test 5\n"; } |
516 | sub test6 { return join ":", __FILE__,__LINE__; } |
517 | package Yet::Another::AutoSplit; |
518 | sub testtesttesttest4_1 ($) { "another test 4\n"; } |
519 | sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; } |
09bef843 |
520 | package Yet::More::Attributes; |
0120eecf |
521 | sub test_a1 ($) : locked :locked { 1; } |
09bef843 |
522 | sub test_a2 : locked { 1; } |