This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Symbian sync
[perl5.git] / lib / AutoSplit.pm
CommitLineData
a0d0e21e
LW
1package AutoSplit;
2
4e6ea2c3
GS
3use Exporter ();
4use Config qw(%Config);
4e6ea2c3 5use File::Basename ();
68dc0745 6use File::Path qw(mkpath);
64a3d80f 7use File::Spec::Functions qw(curdir catfile catdir);
4e6ea2c3 8use strict;
17f410f9
GS
9our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
10 $CheckForAutoloader, $CheckModTime);
a0d0e21e 11
9938a85f 12$VERSION = "1.05";
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
19AutoSplit - 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
29This function will split up your program into files that the AutoLoader
21c92a1d
PP
30module can handle. It is used by both the standard perl libraries and by
31the MakeMaker utility, to automatically configure libraries for autoloading.
32
33The C<autosplit> interface splits the specified file into a hierarchy
34rooted at the directory C<$dir>. It creates directories as needed to reflect
35class hierarchy, and creates the file F<autosplit.ix>. This file acts as
36both forward declaration of all package routines, and as timestamp for the
37last update of the hierarchy.
38
4e6ea2c3
GS
39The remaining three arguments to C<autosplit> govern other options to
40the autosplitter.
41
42=over 2
43
44=item $keep
45
46If the third argument, I<$keep>, is false, then any
47pre-existing C<*.al> files in the autoload directory are removed if
48they are no longer part of the module (obsoleted functions).
49$keep defaults to 0.
50
51=item $check
52
53The
54fourth argument, I<$check>, instructs C<autosplit> to check the module
e8fac187 55currently being split to ensure that it includes a C<use>
4e6ea2c3
GS
56specification for the AutoLoader module, and skips the module if
57AutoLoader is not detected.
58$check defaults to 1.
59
60=item $modtime
61
62Lastly, the I<$modtime> argument specifies
63that C<autosplit> is to check the modification time of the module
64against that of the C<autosplit.ix> file, and only split the module if
65it is newer.
66$modtime defaults to 1.
67
68=back
21c92a1d
PP
69
70Typical use of AutoSplit in the perl MakeMaker utility is via the command-line
71with:
72
73 perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)'
74
75Defined as a Make macro, it is invoked with file and directory arguments;
76C<autosplit> will split the specified file into the specified directory and
77delete obsolete C<.al> files, after checking first that the module does use
78the AutoLoader, and ensuring that the module is not already currently split
79in its current form (the modtime test).
80
81The C<autosplit_lib_modules> form is used in the building of perl. It takes
82as input a list of files (modules) that are assumed to reside in a directory
83B<lib> relative to the current directory. Each file is sent to the
84autosplitter one at a time, to be split into the directory B<lib/auto>.
85
86In both usages of the autosplitter, only subroutines defined following the
4e6ea2c3 87perl I<__END__> token are split out into separate files. Some
21c92a1d
PP
88routines may be placed prior to this marker to force their immediate loading
89and parsing.
90
4e6ea2c3
GS
91=head2 Multiple packages
92
93As of version 1.01 of the AutoSplit module it is possible to have
94multiple packages within a single file. Both of the following cases
95are 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
PP
110
111=head1 DIAGNOSTICS
112
4e6ea2c3
GS
113C<AutoSplit> will inform the user if it is necessary to create the
114top-level directory specified in the invocation. It is preferred that
115the script or installation process that invokes C<AutoSplit> have
116created the full directory path ahead of time. This warning may
117indicate that the module is being split into an incorrect path.
21c92a1d 118
4e6ea2c3
GS
119C<AutoSplit> will warn the user of all subroutines whose name causes
120potential file naming conflicts on machines with drastically limited
121(8 characters or less) file name length. Since the subroutine name is
122used as the file name, these warnings can aid in portability to such
123systems.
21c92a1d 124
4e6ea2c3
GS
125Warnings are issued and the file skipped if C<AutoSplit> cannot locate
126either the I<__END__> marker or a "package Name;"-style specification.
21c92a1d 127
4e6ea2c3
GS
128C<AutoSplit> will also emit general diagnostics for inability to
129create directories or files.
f06db76b
AD
130
131=cut
132
a0d0e21e
LW
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
TB
137$CheckForAutoloader = 1;
138$CheckModTime = 1;
a0d0e21e 139
4e6ea2c3
GS
140my $IndexFile = "autosplit.ix"; # file also serves as timestamp
141my $maxflen = 255;
a0d0e21e 142$maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
39e571d4
ML
143if (defined (&Dos::UseLFN)) {
144 $maxflen = Dos::UseLFN() ? 255 : 11;
145}
4e6ea2c3 146my $Is_VMS = ($^O eq 'VMS');
a0d0e21e 147
4764e399
JH
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
JH
152my $attr_list =
153 $] >= 5.009005 ?
154 eval <<'__QR__'
155 qr{
91798d18
RGS
156 \s* : \s*
157 (?:
158 # one attribute
159 (?> # no backtrack
160 (?! \d) \w+
161 (?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ?
162 )
163 (?: \s* : \s* | \s+ (?! :) )
164 )*
4764e399
JH
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 178sub autosplit{
4e6ea2c3 179 my($file, $autodir, $keep, $ckal, $ckmt) = @_;
75f92628
AD
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
AD
184 $ckal = $CheckForAutoloader unless defined $ckal;
185 $ckmt = $CheckModTime unless defined $ckmt;
186 autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
a0d0e21e
LW
187}
188
8878f897
T
189sub 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 197sub autosplit_lib_modules {
a0d0e21e 198 my(@modules) = @_; # list of Module names
4764e399
JH
199 local $_; # Avoid clobber.
200 while (defined($_ = shift @modules)) {
9938a85f 201 while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ
0eb04855
GS
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
JH
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
GS
212 my ($dir,$name) = (/(.*])(.*)/s);
213 $dir =~ s/.*lib[\.\]]//s;
a0d0e21e
LW
214 $dir =~ s#[\.\]]#/#g;
215 $_ = $dir . $name;
216 }
0eb04855 217 autosplit_file(catfile($lib, $_), catfile($lib, "auto"),
4e6ea2c3 218 $Keep, $CheckForAutoloader, $CheckModTime);
a0d0e21e
LW
219 }
220 0;
221}
222
223
224# private functions
225
e8fac187
MG
226my $self_mod_time = (stat __FILE__)[9];
227
4e6ea2c3
GS
228sub 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
LW
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
PP
239 $filename = VMS::Filespec::unixify($filename); # may have dirs
240 }
3edbfbe5 241 unless (-d $autodir){
68dc0745 242 mkpath($autodir,0,0755);
4e6ea2c3
GS
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
LW
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
LW
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
AD
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
LW
270 ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
271 last if /^__END__/;
272 }
3edbfbe5 273 if ($check_for_autoloader && !$autoloader_seen){
4e6ea2c3
GS
274 print "AutoSplit skipped $filename: no AutoLoader used\n"
275 if ($Verbose>=2);
276 return 0;
3edbfbe5 277 }
a0d0e21e
LW
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
GS
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
LW
293 if ($check_mod_time){
294 my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
e8fac187
MG
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
LW
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
LW
305 if $Verbose;
306
084592ab
CN
307 unless (-d $modnamedir){
308 mkpath($modnamedir,0,0777);
a0d0e21e
LW
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
ML
318 my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames
319
4e6ea2c3 320 my(@subnames, $subname, %proto, %package);
96bc026d
CS
321 my @cache = ();
322 my $caching = 1;
4e6ea2c3 323 $last_package = '';
b6c146dd
MS
324 my $out;
325 while (<$in>) {
4e6ea2c3 326 $fnr++;
53667d02 327 $in_pod = 1 if /^=\w/;
4e6ea2c3
GS
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
GS
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
GS
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
GS
355 my($lpath) = catfile($modnamedir, "$lname.al");
356 my($spath) = catfile($modnamedir, "$sname.al");
4e6ea2c3 357 my $path;
b6c146dd
MS
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
GS
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
GS
373# See AutoSplit.pm.
374package $this_package;
375
e8fac187 376#line $lineno "$filename (autosplit into $path)"
4e6ea2c3 377EOT
b6c146dd 378 print $out @cache;
96bc026d
CS
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
CS
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
MS
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
GS
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
GS
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
MS
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
GS
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
LW
434 }
435
b6c146dd 436 open(my $ts,">$al_idx_file") or
8878f897 437 carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!");
b6c146dd
MS
438 print $ts "# Index created by AutoSplit for $filename\n";
439 print $ts "# (file acts as timestamp)\n";
4e6ea2c3
GS
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
GS
447 $last_package = $package{$fqs};
448 }
b6c146dd
MS
449 print $ts "1;\n";
450 close($ts);
a0d0e21e 451
4e6ea2c3 452 _check_unique($filename, $Maxlen, 1, @outfiles);
a0d0e21e 453
4e6ea2c3 454 @outfiles;
a0d0e21e
LW
455}
456
4e6ea2c3
GS
457sub _modpname ($) {
458 my($package) = @_;
459 my $modpname = $package;
460 if ($^O eq 'MSWin32') {
461 $modpname =~ s#::#\\#g;
462 } else {
64a3d80f
CB
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
GS
472 }
473 $modpname;
474}
a0d0e21e 475
4e6ea2c3
GS
476sub _check_unique {
477 my($filename, $maxlen, $warn, @outfiles) = @_;
a0d0e21e
LW
478 my(%notuniq) = ();
479 my(%shorts) = ();
4e6ea2c3
GS
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
LW
493 }
494 if (%notuniq && $warn){
4e6ea2c3
GS
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
LW
502 }
503 }
a0d0e21e
LW
504}
505
5061;
507__END__
508
509# test functions so AutoSplit.pm can be applied to itself:
4e6ea2c3
GS
510sub test1 ($) { "test 1\n"; }
511sub test2 ($$) { "test 2\n"; }
512sub test3 ($$$) { "test 3\n"; }
513sub testtesttesttest4_1 { "test 4\n"; }
514sub testtesttesttest4_2 { "duplicate test 4\n"; }
515sub Just::Another::test5 { "another test 5\n"; }
516sub test6 { return join ":", __FILE__,__LINE__; }
517package Yet::Another::AutoSplit;
518sub testtesttesttest4_1 ($) { "another test 4\n"; }
519sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
09bef843 520package Yet::More::Attributes;
0120eecf 521sub test_a1 ($) : locked :locked { 1; }
09bef843 522sub test_a2 : locked { 1; }