line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
package AutoSplit; |
2
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
152552
|
use Exporter (); |
|
1
|
|
|
|
0
|
|
|
1
|
|
|
|
32
|
|
4
|
1
|
|
|
1
|
5
|
use Config qw(%Config); |
|
1
|
|
|
|
2
|
|
|
1
|
|
|
|
45
|
|
5
|
1
|
|
|
1
|
5
|
use File::Basename (); |
|
1
|
|
|
|
3
|
|
|
1
|
|
|
|
21
|
|
6
|
1
|
|
|
1
|
6
|
use File::Path qw(mkpath); |
|
1
|
|
|
|
2
|
|
|
1
|
|
|
|
87
|
|
7
|
1
|
|
|
1
|
5
|
use File::Spec::Functions qw(curdir catfile catdir); |
|
1
|
|
|
|
2
|
|
|
1
|
|
|
|
137
|
|
8
|
1
|
|
|
1
|
0
|
use strict; |
|
1
|
|
|
|
0
|
|
|
1
|
|
|
|
4533
|
|
9
|
|
|
|
|
|
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen, |
10
|
|
|
|
|
|
$CheckForAutoloader, $CheckModTime); |
11
|
|
|
|
|
|
|
12
|
|
|
|
|
|
$VERSION = "1.06"; |
13
|
|
|
|
|
|
@ISA = qw(Exporter); |
14
|
|
|
|
|
|
@EXPORT = qw(&autosplit &autosplit_lib_modules); |
15
|
|
|
|
|
|
@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); |
16
|
|
|
|
|
|
|
17
|
|
|
|
|
|
=head1 NAME |
18
|
|
|
|
|
|
|
19
|
|
|
|
|
|
AutoSplit - split a package for autoloading |
20
|
|
|
|
|
|
|
21
|
|
|
|
|
|
=head1 SYNOPSIS |
22
|
|
|
|
|
|
|
23
|
|
|
|
|
|
autosplit($file, $dir, $keep, $check, $modtime); |
24
|
|
|
|
|
|
|
25
|
|
|
|
|
|
autosplit_lib_modules(@modules); |
26
|
|
|
|
|
|
|
27
|
|
|
|
|
|
=head1 DESCRIPTION |
28
|
|
|
|
|
|
|
29
|
|
|
|
|
|
This function will split up your program into files that the AutoLoader |
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 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. This file acts as |
36
|
|
|
|
|
|
both forward declaration of all package routines, and as timestamp for the |
37
|
|
|
|
|
|
last update of the hierarchy. |
38
|
|
|
|
|
|
|
39
|
|
|
|
|
|
The remaining three arguments to C 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 to check the module |
55
|
|
|
|
|
|
currently being split to ensure that it includes a C |
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 is to check the modification time of the module |
64
|
|
|
|
|
|
against that of the C file, and only split the module if |
65
|
|
|
|
|
|
it is newer. |
66
|
|
|
|
|
|
$modtime defaults to 1. |
67
|
|
|
|
|
|
|
68
|
|
|
|
|
|
=back |
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 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 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 relative to the current directory. Each file is sent to the |
84
|
|
|
|
|
|
autosplitter one at a time, to be split into the directory B. |
85
|
|
|
|
|
|
|
86
|
|
|
|
|
|
In both usages of the autosplitter, only subroutines defined following the |
87
|
|
|
|
|
|
perl I<__END__> token are split out into separate files. Some |
88
|
|
|
|
|
|
routines may be placed prior to this marker to force their immediate loading |
89
|
|
|
|
|
|
and parsing. |
90
|
|
|
|
|
|
|
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 { ... } |
104
|
|
|
|
|
|
|
105
|
|
|
|
|
|
package NAME; |
106
|
|
|
|
|
|
__END__ |
107
|
|
|
|
|
|
sub AAA { ... } |
108
|
|
|
|
|
|
sub NAME::option1::BBB { ... } |
109
|
|
|
|
|
|
sub NAME::option2::BBB { ... } |
110
|
|
|
|
|
|
|
111
|
|
|
|
|
|
=head1 DIAGNOSTICS |
112
|
|
|
|
|
|
|
113
|
|
|
|
|
|
C 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 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. |
118
|
|
|
|
|
|
|
119
|
|
|
|
|
|
C 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. |
124
|
|
|
|
|
|
|
125
|
|
|
|
|
|
Warnings are issued and the file skipped if C cannot locate |
126
|
|
|
|
|
|
either the I<__END__> marker or a "package Name;"-style specification. |
127
|
|
|
|
|
|
|
128
|
|
|
|
|
|
C will also emit general diagnostics for inability to |
129
|
|
|
|
|
|
create directories or files. |
130
|
|
|
|
|
|
|
131
|
|
|
|
|
|
=head1 AUTHOR |
132
|
|
|
|
|
|
|
133
|
|
|
|
|
|
C 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 |
139
|
|
|
|
|
|
|
140
|
|
|
|
|
|
Maintainer of the CPAN release: Steffen Mueller |
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, |
151
|
|
|
|
|
|
2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 |
152
|
|
|
|
|
|
by Larry Wall and others |
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
|
|
|
|
|
|
|
201
|
|
|
|
|
|
=cut |
202
|
|
|
|
|
|
|
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; |
207
|
|
|
|
|
|
$CheckForAutoloader = 1; |
208
|
|
|
|
|
|
$CheckModTime = 1; |
209
|
|
|
|
|
|
|
210
|
|
|
|
|
|
my $IndexFile = "autosplit.ix"; # file also serves as timestamp |
211
|
|
|
|
|
|
my $maxflen = 255; |
212
|
|
|
|
|
|
$maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; |
213
|
|
|
|
|
|
if (defined (&Dos::UseLFN)) { |
214
|
|
|
|
|
|
$maxflen = Dos::UseLFN() ? 255 : 11; |
215
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
my $Is_VMS = ($^O eq 'VMS'); |
217
|
|
|
|
|
|
|
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) |
221
|
|
|
|
|
|
|
222
|
|
|
|
|
|
my $attr_list = |
223
|
|
|
|
|
|
$] >= 5.009005 ? |
224
|
|
|
|
|
|
eval <<'__QR__' |
225
|
|
|
|
|
|
qr{ |
226
|
|
|
|
|
|
\s* : \s* |
227
|
|
|
|
|
|
(?: |
228
|
|
|
|
|
|
# one attribute |
229
|
|
|
|
|
|
(?> # no backtrack |
230
|
|
|
|
|
|
(?! \d) \w+ |
231
|
|
|
|
|
|
(? \( (?: [^()]++ | (?&nested)++ )*+ \) ) ? |
232
|
|
|
|
|
|
) |
233
|
|
|
|
|
|
(?: \s* : \s* | \s+ (?! :) ) |
234
|
|
|
|
|
|
)* |
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
|
|
|
|
|
|
}; |
247
|
|
|
|
|
|
|
248
|
|
|
|
|
|
sub autosplit{ |
249
|
0
|
|
|
0
|
|
my($file, $autodir, $keep, $ckal, $ckmt) = @_; |
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: |
253
|
0
|
0
|
|
|
|
$keep = $Keep unless defined $keep; |
254
|
0
|
0
|
|
|
|
$ckal = $CheckForAutoloader unless defined $ckal; |
255
|
0
|
0
|
|
|
|
$ckmt = $CheckModTime unless defined $ckmt; |
256
|
0
|
|
|
|
|
autosplit_file($file, $autodir, $keep, $ckal, $ckmt); |
257
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
259
|
|
|
|
|
|
sub carp{ |
260
|
0
|
|
|
0
|
|
require Carp; |
261
|
0
|
|
|
|
|
goto &Carp::carp; |
262
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
264
|
|
|
|
|
|
# This function is used during perl building/installation |
265
|
|
|
|
|
|
# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ... |
266
|
|
|
|
|
|
|
267
|
|
|
|
|
|
sub autosplit_lib_modules { |
268
|
0
|
|
|
0
|
|
my(@modules) = @_; # list of Module names |
269
|
0
|
|
|
|
|
local $_; # Avoid clobber. |
270
|
0
|
|
|
|
|
while (defined($_ = shift @modules)) { |
271
|
0
|
|
|
|
|
while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ |
272
|
0
|
|
|
|
|
$_ = catfile($1, $2); |
273
|
|
|
|
|
|
} |
274
|
0
|
|
|
|
|
s|\\|/|g; # bug in ksh OS/2 |
275
|
0
|
|
|
|
|
s#^lib/##s; # incase specified as lib/*.pm |
276
|
0
|
|
|
|
|
my($lib) = catfile(curdir(), "lib"); |
277
|
0
|
0
|
|
|
|
if ($Is_VMS) { # may need to convert VMS-style filespecs |
278
|
0
|
|
|
|
|
$lib =~ s#^\[\]#.\/#; |
279
|
|
|
|
|
|
} |
280
|
0
|
|
|
|
|
s#^$lib\W+##s; # incase specified as ./lib/*.pm |
281
|
0
|
0
|
0
|
|
|
if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs |
282
|
0
|
|
|
|
|
my ($dir,$name) = (/(.*])(.*)/s); |
283
|
0
|
|
|
|
|
$dir =~ s/.*lib[\.\]]//s; |
284
|
0
|
|
|
|
|
$dir =~ s#[\.\]]#/#g; |
285
|
0
|
|
|
|
|
$_ = $dir . $name; |
286
|
|
|
|
|
|
} |
287
|
0
|
|
|
|
|
autosplit_file(catfile($lib, $_), catfile($lib, "auto"), |
288
|
|
|
|
|
|
$Keep, $CheckForAutoloader, $CheckModTime); |
289
|
|
|
|
|
|
} |
290
|
0
|
|
|
|
|
0; |
291
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
294
|
|
|
|
|
|
# private functions |
295
|
|
|
|
|
|
|
296
|
|
|
|
|
|
my $self_mod_time = (stat __FILE__)[9]; |
297
|
|
|
|
|
|
|
298
|
|
|
|
|
|
sub autosplit_file { |
299
|
0
|
|
|
0
|
|
my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) |
300
|
|
|
|
|
|
= @_; |
301
|
0
|
|
|
|
|
my(@outfiles); |
302
|
0
|
|
|
|
|
local($_); |
303
|
0
|
|
|
|
|
local($/) = "\n"; |
304
|
|
|
|
|
|
|
305
|
|
|
|
|
|
# where to write output files |
306
|
0
|
|
0
|
|
|
$autodir ||= catfile(curdir(), "lib", "auto"); |
307
|
0
|
0
|
|
|
|
if ($Is_VMS) { |
308
|
0
|
|
|
|
|
($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||; |
309
|
0
|
|
|
|
|
$filename = VMS::Filespec::unixify($filename); # may have dirs |
310
|
|
|
|
|
|
} |
311
|
0
|
0
|
|
|
|
unless (-d $autodir){ |
312
|
0
|
|
|
|
|
mkpath($autodir,0,0755); |
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
|
0
|
|
|
|
|
print "Warning: AutoSplit had to create top-level " . |
318
|
|
|
|
|
|
"$autodir unexpectedly.\n"; |
319
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
321
|
|
|
|
|
|
# allow just a package name to be used |
322
|
0
|
0
|
|
|
|
$filename .= ".pm" unless ($filename =~ m/\.pm\z/); |
323
|
|
|
|
|
|
|
324
|
0
|
0
|
|
|
|
open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n"; |
325
|
0
|
|
|
|
|
my($pm_mod_time) = (stat($filename))[9]; |
326
|
0
|
|
|
|
|
my($autoloader_seen) = 0; |
327
|
0
|
|
|
|
|
my($in_pod) = 0; |
328
|
0
|
|
|
|
|
my($def_package,$last_package,$this_package,$fnr); |
329
|
0
|
|
|
|
|
while (<$in>) { |
330
|
|
|
|
|
|
# Skip pod text. |
331
|
0
|
|
|
|
|
$fnr++; |
332
|
0
|
0
|
|
|
|
$in_pod = 1 if /^=\w/; |
333
|
0
|
0
|
|
|
|
$in_pod = 0 if /^=cut/; |
334
|
0
|
0
|
0
|
|
|
next if ($in_pod || /^=cut/); |
335
|
0
|
0
|
|
|
|
next if /^\s*#/; |
336
|
|
|
|
|
|
|
337
|
|
|
|
|
|
# record last package name seen |
338
|
0
|
0
|
|
|
|
$def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); |
339
|
0
|
0
|
|
|
|
++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/; |
340
|
0
|
0
|
|
|
|
++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; |
341
|
0
|
0
|
|
|
|
last if /^__END__/; |
342
|
|
|
|
|
|
} |
343
|
0
|
0
|
0
|
|
|
if ($check_for_autoloader && !$autoloader_seen){ |
344
|
0
|
0
|
|
|
|
print "AutoSplit skipped $filename: no AutoLoader used\n" |
345
|
|
|
|
|
|
if ($Verbose>=2); |
346
|
0
|
|
|
|
|
return 0; |
347
|
|
|
|
|
|
} |
348
|
0
|
0
|
|
|
|
$_ or die "Can't find __END__ in $filename\n"; |
349
|
|
|
|
|
|
|
350
|
0
|
0
|
|
|
|
$def_package or die "Can't find 'package Name;' in $filename\n"; |
351
|
|
|
|
|
|
|
352
|
0
|
|
|
|
|
my($modpname) = _modpname($def_package); |
353
|
|
|
|
|
|
|
354
|
|
|
|
|
|
# this _has_ to match so we have a reasonable timestamp file |
355
|
0
|
0
|
0
|
|
|
die "Package $def_package ($modpname.pm) does not ". |
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
356
|
|
|
|
|
|
"match filename $filename" |
357
|
|
|
|
|
|
unless ($filename =~ m/\Q$modpname.pm\E$/ or |
358
|
|
|
|
|
|
($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or |
359
|
|
|
|
|
|
$Is_VMS && $filename =~ m/$modpname.pm/i); |
360
|
|
|
|
|
|
|
361
|
0
|
|
|
|
|
my($al_idx_file) = catfile($autodir, $modpname, $IndexFile); |
362
|
|
|
|
|
|
|
363
|
0
|
0
|
|
|
|
if ($check_mod_time){ |
364
|
0
|
|
0
|
|
|
my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; |
365
|
0
|
0
|
0
|
|
|
if ($al_ts_time >= $pm_mod_time and |
366
|
|
|
|
|
|
$al_ts_time >= $self_mod_time){ |
367
|
0
|
0
|
|
|
|
print "AutoSplit skipped ($al_idx_file newer than $filename)\n" |
368
|
|
|
|
|
|
if ($Verbose >= 2); |
369
|
0
|
|
|
|
|
return undef; # one undef, not a list |
370
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
373
|
0
|
|
|
|
|
my($modnamedir) = catdir($autodir, $modpname); |
374
|
0
|
0
|
|
|
|
print "AutoSplitting $filename ($modnamedir)\n" |
375
|
|
|
|
|
|
if $Verbose; |
376
|
|
|
|
|
|
|
377
|
0
|
0
|
|
|
|
unless (-d $modnamedir){ |
378
|
0
|
|
|
|
|
mkpath($modnamedir,0,0777); |
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
|
|
|
|
|
|
|
388
|
0
|
|
|
|
|
my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames |
389
|
|
|
|
|
|
|
390
|
0
|
|
|
|
|
my(@subnames, $subname, %proto, %package); |
391
|
0
|
|
|
|
|
my @cache = (); |
392
|
0
|
|
|
|
|
my $caching = 1; |
393
|
0
|
|
|
|
|
$last_package = ''; |
394
|
0
|
|
|
|
|
my $out; |
395
|
0
|
|
|
|
|
while (<$in>) { |
396
|
0
|
|
|
|
|
$fnr++; |
397
|
0
|
0
|
|
|
|
$in_pod = 1 if /^=\w/; |
398
|
0
|
0
|
|
|
|
$in_pod = 0 if /^=cut/; |
399
|
0
|
0
|
0
|
|
|
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
|
0
|
0
|
|
|
|
if (/^package\s+([\w:]+)\s*;/) { |
404
|
0
|
|
|
|
|
$this_package = $def_package = $1; |
405
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
407
|
0
|
0
|
|
|
|
if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) { |
408
|
0
|
0
|
|
|
|
print $out "# end of $last_package\::$subname\n1;\n" |
409
|
|
|
|
|
|
if $last_package; |
410
|
0
|
|
|
|
|
$subname = $1; |
411
|
0
|
|
0
|
|
|
my $proto = $2 || ''; |
412
|
0
|
0
|
|
|
|
if ($subname =~ s/(.*):://){ |
413
|
0
|
|
|
|
|
$this_package = $1; |
414
|
|
|
|
|
|
} else { |
415
|
0
|
|
|
|
|
$this_package = $def_package; |
416
|
|
|
|
|
|
} |
417
|
0
|
|
|
|
|
my $fq_subname = "$this_package\::$subname"; |
418
|
0
|
|
|
|
|
$package{$fq_subname} = $this_package; |
419
|
0
|
|
|
|
|
$proto{$fq_subname} = $proto; |
420
|
0
|
|
|
|
|
push(@subnames, $fq_subname); |
421
|
0
|
|
|
|
|
my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); |
422
|
0
|
|
|
|
|
$modpname = _modpname($this_package); |
423
|
0
|
|
|
|
|
my($modnamedir) = catdir($autodir, $modpname); |
424
|
0
|
|
|
|
|
mkpath($modnamedir,0,0777); |
425
|
0
|
|
|
|
|
my($lpath) = catfile($modnamedir, "$lname.al"); |
426
|
0
|
|
|
|
|
my($spath) = catfile($modnamedir, "$sname.al"); |
427
|
0
|
|
|
|
|
my $path; |
428
|
|
|
|
|
|
|
429
|
0
|
0
|
0
|
|
|
if (!$Is83 and open($out, ">$lpath")){ |
430
|
0
|
|
|
|
|
$path=$lpath; |
431
|
0
|
0
|
|
|
|
print " writing $lpath\n" if ($Verbose>=2); |
432
|
|
|
|
|
|
} else { |
433
|
0
|
0
|
|
|
|
open($out, ">$spath") or die "Can't create $spath: $!\n"; |
434
|
0
|
|
|
|
|
$path=$spath; |
435
|
0
|
0
|
|
|
|
print " writing $spath (with truncated name)\n" |
436
|
|
|
|
|
|
if ($Verbose>=1); |
437
|
|
|
|
|
|
} |
438
|
0
|
|
|
|
|
push(@outfiles, $path); |
439
|
0
|
|
|
|
|
my $lineno = $fnr - @cache; |
440
|
0
|
|
|
|
|
print $out <
|
441
|
|
|
|
|
|
# NOTE: Derived from $filename. |
442
|
|
|
|
|
|
# Changes made here will be lost when autosplit is run again. |
443
|
|
|
|
|
|
# See AutoSplit.pm. |
444
|
|
|
|
|
|
package $this_package; |
445
|
|
|
|
|
|
|
446
|
|
|
|
|
|
#line $lineno "$filename (autosplit into $path)" |
447
|
|
|
|
|
|
EOT |
448
|
0
|
|
|
|
|
print $out @cache; |
449
|
0
|
|
|
|
|
@cache = (); |
450
|
0
|
|
|
|
|
$caching = 0; |
451
|
|
|
|
|
|
} |
452
|
0
|
0
|
|
|
|
if($caching) { |
453
|
0
|
0
|
0
|
|
|
push(@cache, $_) if @cache || /\S/; |
454
|
|
|
|
|
|
} else { |
455
|
0
|
|
|
|
|
print $out $_; |
456
|
|
|
|
|
|
} |
457
|
0
|
0
|
|
|
|
if(/^\}/) { |
458
|
0
|
0
|
|
|
|
if($caching) { |
459
|
0
|
|
|
|
|
print $out @cache; |
460
|
0
|
|
|
|
|
@cache = (); |
461
|
|
|
|
|
|
} |
462
|
0
|
|
|
|
|
print $out "\n"; |
463
|
0
|
|
|
|
|
$caching = 1; |
464
|
|
|
|
|
|
} |
465
|
0
|
0
|
|
|
|
$last_package = $this_package if defined $this_package; |
466
|
|
|
|
|
|
} |
467
|
0
|
0
|
|
|
|
if ($subname) { |
468
|
0
|
|
|
|
|
print $out @cache,"1;\n# end of $last_package\::$subname\n"; |
469
|
0
|
|
|
|
|
close($out); |
470
|
|
|
|
|
|
} |
471
|
0
|
|
|
|
|
close($in); |
472
|
|
|
|
|
|
|
473
|
0
|
0
|
|
|
|
if (!$keep){ # don't keep any obsolete *.al files in the directory |
474
|
0
|
|
|
|
|
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 |
479
|
|
|
|
|
|
# created. (The mixed case sub name won't match the all-lowercase |
480
|
|
|
|
|
|
# filename, and so be cleaned up as a scrap file) |
481
|
0
|
0
|
0
|
|
|
if ($Is_VMS or $Is83) { |
482
|
0
|
|
|
|
|
%outfiles = map {lc($_) => lc($_) } @outfiles; |
|
0
|
|
|
|
|
|
483
|
|
|
|
|
|
} else { |
484
|
0
|
|
|
|
|
@outfiles{@outfiles} = @outfiles; |
485
|
|
|
|
|
|
} |
486
|
0
|
|
|
|
|
my(%outdirs,@outdirs); |
487
|
0
|
|
|
|
|
for (@outfiles) { |
488
|
0
|
|
0
|
|
|
$outdirs{File::Basename::dirname($_)}||=1; |
489
|
|
|
|
|
|
} |
490
|
0
|
|
|
|
|
for my $dir (keys %outdirs) { |
491
|
0
|
|
|
|
|
opendir(my $outdir,$dir); |
492
|
0
|
|
|
|
|
foreach (sort readdir($outdir)){ |
493
|
0
|
0
|
|
|
|
next unless /\.al\z/; |
494
|
0
|
|
|
|
|
my($file) = catfile($dir, $_); |
495
|
0
|
0
|
0
|
|
|
$file = lc $file if $Is83 or $Is_VMS; |
496
|
0
|
0
|
|
|
|
next if $outfiles{$file}; |
497
|
0
|
0
|
|
|
|
print " deleting $file\n" if ($Verbose>=2); |
498
|
0
|
|
|
|
|
my($deleted,$thistime); # catch all versions on VMS |
499
|
0
|
|
|
|
|
do { $deleted += ($thistime = unlink $file) } while ($thistime); |
|
0
|
|
|
|
|
|
500
|
0
|
0
|
|
|
|
carp ("Unable to delete $file: $!") unless $deleted; |
501
|
|
|
|
|
|
} |
502
|
0
|
|
|
|
|
closedir($outdir); |
503
|
|
|
|
|
|
} |
504
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
506
|
0
|
0
|
|
|
|
open(my $ts,">$al_idx_file") or |
507
|
|
|
|
|
|
carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!"); |
508
|
0
|
|
|
|
|
print $ts "# Index created by AutoSplit for $filename\n"; |
509
|
0
|
|
|
|
|
print $ts "# (file acts as timestamp)\n"; |
510
|
0
|
|
|
|
|
$last_package = ''; |
511
|
0
|
|
|
|
|
for my $fqs (@subnames) { |
512
|
0
|
|
|
|
|
my($subname) = $fqs; |
513
|
0
|
|
|
|
|
$subname =~ s/.*:://; |
514
|
0
|
0
|
|
|
|
print $ts "package $package{$fqs};\n" |
515
|
|
|
|
|
|
unless $last_package eq $package{$fqs}; |
516
|
0
|
|
|
|
|
print $ts "sub $subname $proto{$fqs};\n"; |
517
|
0
|
|
|
|
|
$last_package = $package{$fqs}; |
518
|
|
|
|
|
|
} |
519
|
0
|
|
|
|
|
print $ts "1;\n"; |
520
|
0
|
|
|
|
|
close($ts); |
521
|
|
|
|
|
|
|
522
|
0
|
|
|
|
|
_check_unique($filename, $Maxlen, 1, @outfiles); |
523
|
|
|
|
|
|
|
524
|
0
|
|
|
|
|
@outfiles; |
525
|
|
|
|
|
|
} |
526
|
|
|
|
|
|
|
527
|
|
|
|
|
|
sub _modpname ($) { |
528
|
0
|
|
|
0
|
|
my($package) = @_; |
529
|
0
|
|
|
|
|
my $modpname = $package; |
530
|
0
|
0
|
|
|
|
if ($^O eq 'MSWin32') { |
531
|
0
|
|
|
|
|
$modpname =~ s#::#\\#g; |
532
|
|
|
|
|
|
} else { |
533
|
0
|
|
|
|
|
my @modpnames = (); |
534
|
0
|
|
|
|
|
while ($modpname =~ m#(.*?[^:])::([^:].*)#) { |
535
|
0
|
|
|
|
|
push @modpnames, $1; |
536
|
0
|
|
|
|
|
$modpname = $2; |
537
|
|
|
|
|
|
} |
538
|
0
|
|
|
|
|
$modpname = catfile(@modpnames, $modpname); |
539
|
|
|
|
|
|
} |
540
|
0
|
0
|
|
|
|
if ($Is_VMS) { |
541
|
0
|
|
|
|
|
$modpname = VMS::Filespec::unixify($modpname); # may have dirs |
542
|
|
|
|
|
|
} |
543
|
0
|
|
|
|
|
$modpname; |
544
|
|
|
|
|
|
} |
545
|
|
|
|
|
|
|
546
|
|
|
|
|
|
sub _check_unique { |
547
|
0
|
|
|
0
|
|
my($filename, $maxlen, $warn, @outfiles) = @_; |
548
|
0
|
|
|
|
|
my(%notuniq) = (); |
549
|
0
|
|
|
|
|
my(%shorts) = (); |
550
|
0
|
|
|
|
|
my(@toolong) = grep( |
551
|
|
|
|
|
|
length(File::Basename::basename($_)) |
552
|
|
|
|
|
|
> $maxlen, |
553
|
|
|
|
|
|
@outfiles |
554
|
|
|
|
|
|
); |
555
|
|
|
|
|
|
|
556
|
0
|
|
|
|
|
foreach (@toolong){ |
557
|
0
|
|
|
|
|
my($dir) = File::Basename::dirname($_); |
558
|
0
|
|
|
|
|
my($file) = File::Basename::basename($_); |
559
|
0
|
|
|
|
|
my($trunc) = substr($file,0,$maxlen); |
560
|
0
|
0
|
|
|
|
$notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc}; |
561
|
0
|
0
|
|
|
|
$shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ? |
562
|
|
|
|
|
|
"$shorts{$dir}{$trunc}, $file" : $file; |
563
|
|
|
|
|
|
} |
564
|
0
|
0
|
0
|
|
|
if (%notuniq && $warn){ |
565
|
0
|
|
|
|
|
print "$filename: some names are not unique when " . |
566
|
|
|
|
|
|
"truncated to $maxlen characters:\n"; |
567
|
0
|
|
|
|
|
foreach my $dir (sort keys %notuniq){ |
568
|
0
|
|
|
|
|
print " directory $dir:\n"; |
569
|
0
|
|
|
|
|
foreach my $trunc (sort keys %{$notuniq{$dir}}) { |
|
0
|
|
|
|
|
|
570
|
0
|
|
|
|
|
print " $shorts{$dir}{$trunc} truncate to $trunc\n"; |
571
|
|
|
|
|
|
} |
572
|
|
|
|
|
|
} |
573
|
|
|
|
|
|
} |
574
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
576
|
|
|
|
|
|
1; |
577
|
|
|
|
|
|
__END__ |