Commit | Line | Data |
---|---|---|
a0d0e21e LW |
1 | package AutoSplit; |
2 | ||
4e6ea2c3 GS |
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 GS |
9 | our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen, |
10 | $CheckForAutoloader, $CheckModTime); | |
a0d0e21e | 11 | |
3affb40d | 12 | $VERSION = "1.06"; |
a0d0e21e LW |
13 | @ISA = qw(Exporter); |
14 | @EXPORT = qw(&autosplit &autosplit_lib_modules); | |
3edbfbe5 | 15 | @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); |
a0d0e21e | 16 | |
f06db76b AD |
17 | =head1 NAME |
18 | ||
19 | AutoSplit - split a package for autoloading | |
20 | ||
cb1a09d0 AD |
21 | =head1 SYNOPSIS |
22 | ||
4e6ea2c3 | 23 | autosplit($file, $dir, $keep, $check, $modtime); |
84dc3c4d | 24 | |
4e6ea2c3 | 25 | autosplit_lib_modules(@modules); |
cb1a09d0 | 26 | |
f06db76b AD |
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 GS |
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 GS |
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 GS |
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 GS |
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 GS |
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 GS |
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 GS |
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 GS |
128 | C<AutoSplit> will also emit general diagnostics for inability to |
129 | create directories or files. | |
f06db76b | 130 | |
7a752413 SP |
131 | =head1 AUTHOR |
132 | ||
133 | C<AutoSplit> is maintained by the perl5-porters. Please direct | |
134 | any questions to the canonical mailing list. Anything that | |
135 | is applicable to the CPAN release can be sent to its maintainer, | |
136 | though. | |
137 | ||
138 | Author and Maintainer: The Perl5-Porters <perl5-porters@perl.org> | |
139 | ||
140 | Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org> | |
141 | ||
142 | =head1 COPYRIGHT AND LICENSE | |
143 | ||
144 | This package has been part of the perl core since the first release | |
145 | of perl5. It has been released separately to CPAN so older installations | |
146 | can benefit from bug fixes. | |
147 | ||
148 | This package has the same copyright and license as the perl core: | |
149 | ||
150 | Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, | |
79706302 SP |
151 | 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 |
152 | by Larry Wall and others | |
7a752413 SP |
153 | |
154 | All rights reserved. | |
155 | ||
156 | This program is free software; you can redistribute it and/or modify | |
157 | it under the terms of either: | |
158 | ||
159 | a) the GNU General Public License as published by the Free | |
160 | Software Foundation; either version 1, or (at your option) any | |
161 | later version, or | |
162 | ||
163 | b) the "Artistic License" which comes with this Kit. | |
164 | ||
165 | This program is distributed in the hope that it will be useful, | |
166 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
167 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either | |
168 | the GNU General Public License or the Artistic License for more details. | |
169 | ||
170 | You should have received a copy of the Artistic License with this | |
171 | Kit, in the file named "Artistic". If not, I'll be glad to provide one. | |
172 | ||
173 | You should also have received a copy of the GNU General Public License | |
174 | along with this program in the file named "Copying". If not, write to the | |
175 | Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA | |
176 | 02111-1307, USA or visit their web page on the internet at | |
177 | http://www.gnu.org/copyleft/gpl.html. | |
178 | ||
179 | For those of you that choose to use the GNU General Public License, | |
180 | my interpretation of the GNU General Public License is that no Perl | |
181 | script falls under the terms of the GPL unless you explicitly put | |
182 | said script under the terms of the GPL yourself. Furthermore, any | |
183 | object code linked with perl does not automatically fall under the | |
184 | terms of the GPL, provided such object code only adds definitions | |
185 | of subroutines and variables, and does not otherwise impair the | |
186 | resulting interpreter from executing any standard Perl script. I | |
187 | consider linking in C subroutines in this manner to be the moral | |
188 | equivalent of defining subroutines in the Perl language itself. You | |
189 | may sell such an object file as proprietary provided that you provide | |
190 | or offer to provide the Perl source, as specified by the GNU General | |
191 | Public License. (This is merely an alternate way of specifying input | |
192 | to the program.) You may also sell a binary produced by the dumping of | |
193 | a running Perl script that belongs to you, provided that you provide or | |
194 | offer to provide the Perl source as specified by the GPL. (The | |
195 | fact that a Perl interpreter and your code are in the same binary file | |
196 | is, in this case, a form of mere aggregation.) This is my interpretation | |
197 | of the GPL. If you still have concerns or difficulties understanding | |
198 | my intent, feel free to contact me. Of course, the Artistic License | |
199 | spells all this out for your protection, so you may prefer to use that. | |
200 | ||
f06db76b AD |
201 | =cut |
202 | ||
a0d0e21e LW |
203 | # for portability warn about names longer than $maxlen |
204 | $Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3 | |
205 | $Verbose = 1; # 0=none, 1=minimal, 2=list .al files | |
206 | $Keep = 0; | |
3edbfbe5 TB |
207 | $CheckForAutoloader = 1; |
208 | $CheckModTime = 1; | |
a0d0e21e | 209 | |
4e6ea2c3 GS |
210 | my $IndexFile = "autosplit.ix"; # file also serves as timestamp |
211 | my $maxflen = 255; | |
a0d0e21e | 212 | $maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; |
39e571d4 LM |
213 | if (defined (&Dos::UseLFN)) { |
214 | $maxflen = Dos::UseLFN() ? 255 : 11; | |
215 | } | |
4e6ea2c3 | 216 | my $Is_VMS = ($^O eq 'VMS'); |
a0d0e21e | 217 | |
4764e399 JH |
218 | # allow checking for valid ': attrlist' attachments. |
219 | # extra jugglery required to support both 5.8 and 5.9/5.10 features | |
220 | # (support for 5.8 required for cross-compiling environments) | |
09bef843 | 221 | |
4764e399 JH |
222 | my $attr_list = |
223 | $] >= 5.009005 ? | |
224 | eval <<'__QR__' | |
225 | qr{ | |
91798d18 RGS |
226 | \s* : \s* |
227 | (?: | |
228 | # one attribute | |
229 | (?> # no backtrack | |
230 | (?! \d) \w+ | |
231 | (?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ? | |
232 | ) | |
233 | (?: \s* : \s* | \s+ (?! :) ) | |
234 | )* | |
4764e399 JH |
235 | }x |
236 | __QR__ | |
237 | : | |
238 | do { | |
239 | # In pre-5.9.5 world we have to do dirty tricks. | |
240 | # (we use 'our' rather than 'my' here, due to the rather complex and buggy | |
241 | # behaviour of lexicals with qr// and (??{$lex}) ) | |
242 | our $trick1; # yes, cannot our and assign at the same time. | |
243 | $trick1 = qr{ \( (?: (?> [^()]+ ) | (??{ $trick1 }) )* \) }x; | |
244 | our $trick2 = qr{ (?> (?! \d) \w+ (?:$trick1)? ) (?:\s*\:\s*|\s+(?!\:)) }x; | |
245 | qr{ \s* : \s* (?: $trick2 )* }x; | |
246 | }; | |
3edbfbe5 | 247 | |
a0d0e21e | 248 | sub autosplit{ |
4e6ea2c3 | 249 | my($file, $autodir, $keep, $ckal, $ckmt) = @_; |
75f92628 AD |
250 | # $file - the perl source file to be split (after __END__) |
251 | # $autodir - the ".../auto" dir below which to write split subs | |
252 | # Handle optional flags: | |
4e6ea2c3 | 253 | $keep = $Keep unless defined $keep; |
75f92628 AD |
254 | $ckal = $CheckForAutoloader unless defined $ckal; |
255 | $ckmt = $CheckModTime unless defined $ckmt; | |
256 | autosplit_file($file, $autodir, $keep, $ckal, $ckmt); | |
a0d0e21e LW |
257 | } |
258 | ||
8878f897 T |
259 | sub carp{ |
260 | require Carp; | |
261 | goto &Carp::carp; | |
262 | } | |
a0d0e21e | 263 | |
a0d0e21e | 264 | # This function is used during perl building/installation |
21c92a1d | 265 | # ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ... |
a0d0e21e | 266 | |
9938a85f | 267 | sub autosplit_lib_modules { |
a0d0e21e | 268 | my(@modules) = @_; # list of Module names |
4764e399 JH |
269 | local $_; # Avoid clobber. |
270 | while (defined($_ = shift @modules)) { | |
9938a85f | 271 | while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ |
0eb04855 GS |
272 | $_ = catfile($1, $2); |
273 | } | |
4633a7c4 | 274 | s|\\|/|g; # bug in ksh OS/2 |
413e5597 | 275 | s#^lib/##s; # incase specified as lib/*.pm |
0eb04855 | 276 | my($lib) = catfile(curdir(), "lib"); |
b1179839 JH |
277 | if ($Is_VMS) { # may need to convert VMS-style filespecs |
278 | $lib =~ s#^\[\]#.\/#; | |
279 | } | |
413e5597 | 280 | s#^$lib\W+##s; # incase specified as ./lib/*.pm |
c6538b72 | 281 | if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs |
14a089c5 GS |
282 | my ($dir,$name) = (/(.*])(.*)/s); |
283 | $dir =~ s/.*lib[\.\]]//s; | |
a0d0e21e LW |
284 | $dir =~ s#[\.\]]#/#g; |
285 | $_ = $dir . $name; | |
286 | } | |
0eb04855 | 287 | autosplit_file(catfile($lib, $_), catfile($lib, "auto"), |
4e6ea2c3 | 288 | $Keep, $CheckForAutoloader, $CheckModTime); |
a0d0e21e LW |
289 | } |
290 | 0; | |
291 | } | |
292 | ||
293 | ||
294 | # private functions | |
295 | ||
e8fac187 MG |
296 | my $self_mod_time = (stat __FILE__)[9]; |
297 | ||
4e6ea2c3 GS |
298 | sub autosplit_file { |
299 | my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) | |
300 | = @_; | |
301 | my(@outfiles); | |
6e7678af | 302 | local($_); |
4e6ea2c3 | 303 | local($/) = "\n"; |
a0d0e21e LW |
304 | |
305 | # where to write output files | |
0eb04855 | 306 | $autodir ||= catfile(curdir(), "lib", "auto"); |
f86702cc | 307 | if ($Is_VMS) { |
14a089c5 | 308 | ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||; |
f86702cc | 309 | $filename = VMS::Filespec::unixify($filename); # may have dirs |
310 | } | |
3edbfbe5 | 311 | unless (-d $autodir){ |
68dc0745 | 312 | mkpath($autodir,0,0755); |
4e6ea2c3 GS |
313 | # We should never need to create the auto dir |
314 | # here. installperl (or similar) should have done | |
315 | # it. Expecting it to exist is a valuable sanity check against | |
316 | # autosplitting into some random directory by mistake. | |
317 | print "Warning: AutoSplit had to create top-level " . | |
318 | "$autodir unexpectedly.\n"; | |
3edbfbe5 | 319 | } |
a0d0e21e LW |
320 | |
321 | # allow just a package name to be used | |
14a089c5 | 322 | $filename .= ".pm" unless ($filename =~ m/\.pm\z/); |
a0d0e21e | 323 | |
b6c146dd | 324 | open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n"; |
a0d0e21e LW |
325 | my($pm_mod_time) = (stat($filename))[9]; |
326 | my($autoloader_seen) = 0; | |
f06db76b | 327 | my($in_pod) = 0; |
4e6ea2c3 | 328 | my($def_package,$last_package,$this_package,$fnr); |
b6c146dd | 329 | while (<$in>) { |
f06db76b | 330 | # Skip pod text. |
4e6ea2c3 | 331 | $fnr++; |
697fd008 | 332 | $in_pod = 1 if /^=\w/; |
f06db76b AD |
333 | $in_pod = 0 if /^=cut/; |
334 | next if ($in_pod || /^=cut/); | |
fe169e07 | 335 | next if /^\s*#/; |
f06db76b | 336 | |
a0d0e21e | 337 | # record last package name seen |
4e6ea2c3 | 338 | $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); |
3edbfbe5 | 339 | ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/; |
a0d0e21e LW |
340 | ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; |
341 | last if /^__END__/; | |
342 | } | |
3edbfbe5 | 343 | if ($check_for_autoloader && !$autoloader_seen){ |
4e6ea2c3 GS |
344 | print "AutoSplit skipped $filename: no AutoLoader used\n" |
345 | if ($Verbose>=2); | |
346 | return 0; | |
3edbfbe5 | 347 | } |
a0d0e21e LW |
348 | $_ or die "Can't find __END__ in $filename\n"; |
349 | ||
4e6ea2c3 | 350 | $def_package or die "Can't find 'package Name;' in $filename\n"; |
a0d0e21e | 351 | |
4e6ea2c3 | 352 | my($modpname) = _modpname($def_package); |
a0d0e21e | 353 | |
4e6ea2c3 GS |
354 | # this _has_ to match so we have a reasonable timestamp file |
355 | die "Package $def_package ($modpname.pm) does not ". | |
356 | "match filename $filename" | |
68dc0745 | 357 | unless ($filename =~ m/\Q$modpname.pm\E$/ or |
2986a63f | 358 | ($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or |
c6538b72 | 359 | $Is_VMS && $filename =~ m/$modpname.pm/i); |
a0d0e21e | 360 | |
084592ab | 361 | my($al_idx_file) = catfile($autodir, $modpname, $IndexFile); |
68dc0745 | 362 | |
a0d0e21e LW |
363 | if ($check_mod_time){ |
364 | my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; | |
e8fac187 MG |
365 | if ($al_ts_time >= $pm_mod_time and |
366 | $al_ts_time >= $self_mod_time){ | |
4e6ea2c3 | 367 | print "AutoSplit skipped ($al_idx_file newer than $filename)\n" |
a0d0e21e LW |
368 | if ($Verbose >= 2); |
369 | return undef; # one undef, not a list | |
370 | } | |
371 | } | |
372 | ||
64a3d80f | 373 | my($modnamedir) = catdir($autodir, $modpname); |
0eb04855 | 374 | print "AutoSplitting $filename ($modnamedir)\n" |
a0d0e21e LW |
375 | if $Verbose; |
376 | ||
084592ab CN |
377 | unless (-d $modnamedir){ |
378 | mkpath($modnamedir,0,0777); | |
a0d0e21e LW |
379 | } |
380 | ||
381 | # We must try to deal with some SVR3 systems with a limit of 14 | |
382 | # characters for file names. Sadly we *cannot* simply truncate all | |
383 | # file names to 14 characters on these systems because we *must* | |
384 | # create filenames which exactly match the names used by AutoLoader.pm. | |
385 | # This is a problem because some systems silently truncate the file | |
386 | # names while others treat long file names as an error. | |
387 | ||
39e571d4 LM |
388 | my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames |
389 | ||
4e6ea2c3 | 390 | my(@subnames, $subname, %proto, %package); |
96bc026d CS |
391 | my @cache = (); |
392 | my $caching = 1; | |
4e6ea2c3 | 393 | $last_package = ''; |
b6c146dd MS |
394 | my $out; |
395 | while (<$in>) { | |
4e6ea2c3 | 396 | $fnr++; |
53667d02 | 397 | $in_pod = 1 if /^=\w/; |
4e6ea2c3 GS |
398 | $in_pod = 0 if /^=cut/; |
399 | next if ($in_pod || /^=cut/); | |
400 | # the following (tempting) old coding gives big troubles if a | |
401 | # cut is forgotten at EOF: | |
402 | # next if /^=\w/ .. /^=cut/; | |
403 | if (/^package\s+([\w:]+)\s*;/) { | |
404 | $this_package = $def_package = $1; | |
a0d0e21e | 405 | } |
b6c146dd | 406 | |
09bef843 | 407 | if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) { |
b6c146dd | 408 | print $out "# end of $last_package\::$subname\n1;\n" |
4e6ea2c3 GS |
409 | if $last_package; |
410 | $subname = $1; | |
411 | my $proto = $2 || ''; | |
412 | if ($subname =~ s/(.*):://){ | |
413 | $this_package = $1; | |
414 | } else { | |
415 | $this_package = $def_package; | |
a0d0e21e | 416 | } |
4e6ea2c3 GS |
417 | my $fq_subname = "$this_package\::$subname"; |
418 | $package{$fq_subname} = $this_package; | |
419 | $proto{$fq_subname} = $proto; | |
420 | push(@subnames, $fq_subname); | |
a0d0e21e | 421 | my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); |
4e6ea2c3 | 422 | $modpname = _modpname($this_package); |
64a3d80f | 423 | my($modnamedir) = catdir($autodir, $modpname); |
084592ab | 424 | mkpath($modnamedir,0,0777); |
0eb04855 GS |
425 | my($lpath) = catfile($modnamedir, "$lname.al"); |
426 | my($spath) = catfile($modnamedir, "$sname.al"); | |
4e6ea2c3 | 427 | my $path; |
b6c146dd MS |
428 | |
429 | if (!$Is83 and open($out, ">$lpath")){ | |
4e6ea2c3 | 430 | $path=$lpath; |
a0d0e21e | 431 | print " writing $lpath\n" if ($Verbose>=2); |
4e6ea2c3 | 432 | } else { |
b6c146dd | 433 | open($out, ">$spath") or die "Can't create $spath: $!\n"; |
4e6ea2c3 GS |
434 | $path=$spath; |
435 | print " writing $spath (with truncated name)\n" | |
436 | if ($Verbose>=1); | |
a0d0e21e | 437 | } |
4e6ea2c3 | 438 | push(@outfiles, $path); |
e8fac187 | 439 | my $lineno = $fnr - @cache; |
b6c146dd | 440 | print $out <<EOT; |
4e6ea2c3 | 441 | # NOTE: Derived from $filename. |
e8fac187 | 442 | # Changes made here will be lost when autosplit is run again. |
4e6ea2c3 GS |
443 | # See AutoSplit.pm. |
444 | package $this_package; | |
445 | ||
e8fac187 | 446 | #line $lineno "$filename (autosplit into $path)" |
4e6ea2c3 | 447 | EOT |
b6c146dd | 448 | print $out @cache; |
96bc026d CS |
449 | @cache = (); |
450 | $caching = 0; | |
451 | } | |
452 | if($caching) { | |
453 | push(@cache, $_) if @cache || /\S/; | |
4e6ea2c3 | 454 | } else { |
b6c146dd | 455 | print $out $_; |
96bc026d | 456 | } |
4e6ea2c3 | 457 | if(/^\}/) { |
96bc026d | 458 | if($caching) { |
b6c146dd | 459 | print $out @cache; |
96bc026d CS |
460 | @cache = (); |
461 | } | |
b6c146dd | 462 | print $out "\n"; |
96bc026d | 463 | $caching = 1; |
a0d0e21e | 464 | } |
4e6ea2c3 | 465 | $last_package = $this_package if defined $this_package; |
a0d0e21e | 466 | } |
548da3d2 | 467 | if ($subname) { |
b6c146dd MS |
468 | print $out @cache,"1;\n# end of $last_package\::$subname\n"; |
469 | close($out); | |
548da3d2 | 470 | } |
b6c146dd | 471 | close($in); |
4e6ea2c3 | 472 | |
a0d0e21e | 473 | if (!$keep){ # don't keep any obsolete *.al files in the directory |
4e6ea2c3 GS |
474 | my(%outfiles); |
475 | # @outfiles{@outfiles} = @outfiles; | |
476 | # perl downcases all filenames on VMS (which upcases all filenames) so | |
477 | # we'd better downcase the sub name list too, or subs with upper case | |
478 | # letters in them will get their .al files deleted right after they're | |
8f8c40b1 | 479 | # created. (The mixed case sub name won't match the all-lowercase |
4e6ea2c3 GS |
480 | # filename, and so be cleaned up as a scrap file) |
481 | if ($Is_VMS or $Is83) { | |
482 | %outfiles = map {lc($_) => lc($_) } @outfiles; | |
483 | } else { | |
484 | @outfiles{@outfiles} = @outfiles; | |
485 | } | |
486 | my(%outdirs,@outdirs); | |
487 | for (@outfiles) { | |
488 | $outdirs{File::Basename::dirname($_)}||=1; | |
489 | } | |
490 | for my $dir (keys %outdirs) { | |
b6c146dd MS |
491 | opendir(my $outdir,$dir); |
492 | foreach (sort readdir($outdir)){ | |
14a089c5 | 493 | next unless /\.al\z/; |
0eb04855 | 494 | my($file) = catfile($dir, $_); |
8f8c40b1 | 495 | $file = lc $file if $Is83 or $Is_VMS; |
4e6ea2c3 GS |
496 | next if $outfiles{$file}; |
497 | print " deleting $file\n" if ($Verbose>=2); | |
498 | my($deleted,$thistime); # catch all versions on VMS | |
499 | do { $deleted += ($thistime = unlink $file) } while ($thistime); | |
8878f897 | 500 | carp ("Unable to delete $file: $!") unless $deleted; |
4e6ea2c3 | 501 | } |
b6c146dd | 502 | closedir($outdir); |
a0d0e21e | 503 | } |
a0d0e21e LW |
504 | } |
505 | ||
b6c146dd | 506 | open(my $ts,">$al_idx_file") or |
8878f897 | 507 | carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!"); |
b6c146dd MS |
508 | print $ts "# Index created by AutoSplit for $filename\n"; |
509 | print $ts "# (file acts as timestamp)\n"; | |
4e6ea2c3 GS |
510 | $last_package = ''; |
511 | for my $fqs (@subnames) { | |
512 | my($subname) = $fqs; | |
513 | $subname =~ s/.*:://; | |
b6c146dd | 514 | print $ts "package $package{$fqs};\n" |
4e6ea2c3 | 515 | unless $last_package eq $package{$fqs}; |
b6c146dd | 516 | print $ts "sub $subname $proto{$fqs};\n"; |
4e6ea2c3 GS |
517 | $last_package = $package{$fqs}; |
518 | } | |
b6c146dd MS |
519 | print $ts "1;\n"; |
520 | close($ts); | |
a0d0e21e | 521 | |
4e6ea2c3 | 522 | _check_unique($filename, $Maxlen, 1, @outfiles); |
a0d0e21e | 523 | |
4e6ea2c3 | 524 | @outfiles; |
a0d0e21e LW |
525 | } |
526 | ||
4e6ea2c3 GS |
527 | sub _modpname ($) { |
528 | my($package) = @_; | |
529 | my $modpname = $package; | |
530 | if ($^O eq 'MSWin32') { | |
531 | $modpname =~ s#::#\\#g; | |
532 | } else { | |
64a3d80f CB |
533 | my @modpnames = (); |
534 | while ($modpname =~ m#(.*?[^:])::([^:].*)#) { | |
535 | push @modpnames, $1; | |
536 | $modpname = $2; | |
537 | } | |
538 | $modpname = catfile(@modpnames, $modpname); | |
539 | } | |
540 | if ($Is_VMS) { | |
541 | $modpname = VMS::Filespec::unixify($modpname); # may have dirs | |
4e6ea2c3 GS |
542 | } |
543 | $modpname; | |
544 | } | |
a0d0e21e | 545 | |
4e6ea2c3 GS |
546 | sub _check_unique { |
547 | my($filename, $maxlen, $warn, @outfiles) = @_; | |
a0d0e21e LW |
548 | my(%notuniq) = (); |
549 | my(%shorts) = (); | |
4e6ea2c3 GS |
550 | my(@toolong) = grep( |
551 | length(File::Basename::basename($_)) | |
552 | > $maxlen, | |
553 | @outfiles | |
554 | ); | |
555 | ||
556 | foreach (@toolong){ | |
557 | my($dir) = File::Basename::dirname($_); | |
558 | my($file) = File::Basename::basename($_); | |
559 | my($trunc) = substr($file,0,$maxlen); | |
560 | $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc}; | |
561 | $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ? | |
562 | "$shorts{$dir}{$trunc}, $file" : $file; | |
a0d0e21e LW |
563 | } |
564 | if (%notuniq && $warn){ | |
4e6ea2c3 GS |
565 | print "$filename: some names are not unique when " . |
566 | "truncated to $maxlen characters:\n"; | |
567 | foreach my $dir (sort keys %notuniq){ | |
568 | print " directory $dir:\n"; | |
569 | foreach my $trunc (sort keys %{$notuniq{$dir}}) { | |
570 | print " $shorts{$dir}{$trunc} truncate to $trunc\n"; | |
571 | } | |
a0d0e21e LW |
572 | } |
573 | } | |
a0d0e21e LW |
574 | } |
575 | ||
576 | 1; | |
577 | __END__ | |
578 | ||
579 | # test functions so AutoSplit.pm can be applied to itself: | |
4e6ea2c3 GS |
580 | sub test1 ($) { "test 1\n"; } |
581 | sub test2 ($$) { "test 2\n"; } | |
582 | sub test3 ($$$) { "test 3\n"; } | |
583 | sub testtesttesttest4_1 { "test 4\n"; } | |
584 | sub testtesttesttest4_2 { "duplicate test 4\n"; } | |
585 | sub Just::Another::test5 { "another test 5\n"; } | |
586 | sub test6 { return join ":", __FILE__,__LINE__; } | |
587 | package Yet::Another::AutoSplit; | |
588 | sub testtesttesttest4_1 ($) { "another test 4\n"; } | |
589 | sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; } | |
09bef843 | 590 | package Yet::More::Attributes; |
0120eecf | 591 | sub test_a1 ($) : locked :locked { 1; } |
09bef843 | 592 | sub test_a2 : locked { 1; } |