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