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