1package AutoSplit; 2 3use 5.006_001; 4use Exporter (); 5use Config qw(%Config); 6use Carp qw(carp); 7use File::Basename (); 8use File::Path qw(mkpath); 9use File::Spec::Functions qw(curdir catfile catdir); 10use strict; 11our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen, 12 $CheckForAutoloader, $CheckModTime); 13 14$VERSION = "1.04"; 15@ISA = qw(Exporter); 16@EXPORT = qw(&autosplit &autosplit_lib_modules); 17@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); 18 19=head1 NAME 20 21AutoSplit - split a package for autoloading 22 23=head1 SYNOPSIS 24 25 autosplit($file, $dir, $keep, $check, $modtime); 26 27 autosplit_lib_modules(@modules); 28 29=head1 DESCRIPTION 30 31This function will split up your program into files that the AutoLoader 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 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 57currently being split to ensure that it includes a C<use> 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 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 89perl I<__END__> token are split out into separate files. Some 90routines may be placed prior to this marker to force their immediate loading 91and parsing. 92 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 { ... } 106 107 package NAME; 108 __END__ 109 sub AAA { ... } 110 sub NAME::option1::BBB { ... } 111 sub NAME::option2::BBB { ... } 112 113=head1 DIAGNOSTICS 114 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. 120 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. 126 127Warnings are issued and the file skipped if C<AutoSplit> cannot locate 128either the I<__END__> marker or a "package Name;"-style specification. 129 130C<AutoSplit> will also emit general diagnostics for inability to 131create directories or files. 132 133=cut 134 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; 139$CheckForAutoloader = 1; 140$CheckModTime = 1; 141 142my $IndexFile = "autosplit.ix"; # file also serves as timestamp 143my $maxflen = 255; 144$maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; 145if (defined (&Dos::UseLFN)) { 146 $maxflen = Dos::UseLFN() ? 255 : 11; 147} 148my $Is_VMS = ($^O eq 'VMS'); 149 150# allow checking for valid ': attrlist' attachments 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; 154$nested = qr{ \( (?: (?> [^()]+ ) | (??{ $nested }) )* \) }x; 155our $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x; 156our $attr_list = qr{ \s* : \s* (?: $one_attr )* }x; 157 158 159 160sub autosplit{ 161 my($file, $autodir, $keep, $ckal, $ckmt) = @_; 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: 165 $keep = $Keep unless defined $keep; 166 $ckal = $CheckForAutoloader unless defined $ckal; 167 $ckmt = $CheckModTime unless defined $ckmt; 168 autosplit_file($file, $autodir, $keep, $ckal, $ckmt); 169} 170 171 172# This function is used during perl building/installation 173# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ... 174 175sub autosplit_lib_modules{ 176 my(@modules) = @_; # list of Module names 177 178 while(defined($_ = shift @modules)){ 179 while (m#(.*?[^:])::([^:].*)#) { # in case specified as ABC::XYZ 180 $_ = catfile($1, $2); 181 } 182 s|\\|/|g; # bug in ksh OS/2 183 s#^lib/##s; # incase specified as lib/*.pm 184 my($lib) = catfile(curdir(), "lib"); 185 if ($Is_VMS) { # may need to convert VMS-style filespecs 186 $lib =~ s#^\[\]#.\/#; 187 } 188 s#^$lib\W+##s; # incase specified as ./lib/*.pm 189 if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs 190 my ($dir,$name) = (/(.*])(.*)/s); 191 $dir =~ s/.*lib[\.\]]//s; 192 $dir =~ s#[\.\]]#/#g; 193 $_ = $dir . $name; 194 } 195 autosplit_file(catfile($lib, $_), catfile($lib, "auto"), 196 $Keep, $CheckForAutoloader, $CheckModTime); 197 } 198 0; 199} 200 201 202# private functions 203 204my $self_mod_time = (stat __FILE__)[9]; 205 206sub autosplit_file { 207 my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) 208 = @_; 209 my(@outfiles); 210 local($_); 211 local($/) = "\n"; 212 213 # where to write output files 214 $autodir ||= catfile(curdir(), "lib", "auto"); 215 if ($Is_VMS) { 216 ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||; 217 $filename = VMS::Filespec::unixify($filename); # may have dirs 218 } 219 unless (-d $autodir){ 220 mkpath($autodir,0,0755); 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"; 227 } 228 229 # allow just a package name to be used 230 $filename .= ".pm" unless ($filename =~ m/\.pm\z/); 231 232 open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n"; 233 my($pm_mod_time) = (stat($filename))[9]; 234 my($autoloader_seen) = 0; 235 my($in_pod) = 0; 236 my($def_package,$last_package,$this_package,$fnr); 237 while (<$in>) { 238 # Skip pod text. 239 $fnr++; 240 $in_pod = 1 if /^=\w/; 241 $in_pod = 0 if /^=cut/; 242 next if ($in_pod || /^=cut/); 243 next if /^\s*#/; 244 245 # record last package name seen 246 $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); 247 ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/; 248 ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; 249 last if /^__END__/; 250 } 251 if ($check_for_autoloader && !$autoloader_seen){ 252 print "AutoSplit skipped $filename: no AutoLoader used\n" 253 if ($Verbose>=2); 254 return 0; 255 } 256 $_ or die "Can't find __END__ in $filename\n"; 257 258 $def_package or die "Can't find 'package Name;' in $filename\n"; 259 260 my($modpname) = _modpname($def_package); 261 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" 265 unless ($filename =~ m/\Q$modpname.pm\E$/ or 266 ($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or 267 $Is_VMS && $filename =~ m/$modpname.pm/i); 268 269 my($al_idx_file) = catfile($autodir, $modpname, $IndexFile); 270 271 if ($check_mod_time){ 272 my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; 273 if ($al_ts_time >= $pm_mod_time and 274 $al_ts_time >= $self_mod_time){ 275 print "AutoSplit skipped ($al_idx_file newer than $filename)\n" 276 if ($Verbose >= 2); 277 return undef; # one undef, not a list 278 } 279 } 280 281 my($modnamedir) = catdir($autodir, $modpname); 282 print "AutoSplitting $filename ($modnamedir)\n" 283 if $Verbose; 284 285 unless (-d $modnamedir){ 286 mkpath($modnamedir,0,0777); 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 296 my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames 297 298 my(@subnames, $subname, %proto, %package); 299 my @cache = (); 300 my $caching = 1; 301 $last_package = ''; 302 my $out; 303 while (<$in>) { 304 $fnr++; 305 $in_pod = 1 if /^=\w/; 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; 313 } 314 315 if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) { 316 print $out "# end of $last_package\::$subname\n1;\n" 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; 324 } 325 my $fq_subname = "$this_package\::$subname"; 326 $package{$fq_subname} = $this_package; 327 $proto{$fq_subname} = $proto; 328 push(@subnames, $fq_subname); 329 my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); 330 $modpname = _modpname($this_package); 331 my($modnamedir) = catdir($autodir, $modpname); 332 mkpath($modnamedir,0,0777); 333 my($lpath) = catfile($modnamedir, "$lname.al"); 334 my($spath) = catfile($modnamedir, "$sname.al"); 335 my $path; 336 337 if (!$Is83 and open($out, ">$lpath")){ 338 $path=$lpath; 339 print " writing $lpath\n" if ($Verbose>=2); 340 } else { 341 open($out, ">$spath") or die "Can't create $spath: $!\n"; 342 $path=$spath; 343 print " writing $spath (with truncated name)\n" 344 if ($Verbose>=1); 345 } 346 push(@outfiles, $path); 347 my $lineno = $fnr - @cache; 348 print $out <<EOT; 349# NOTE: Derived from $filename. 350# Changes made here will be lost when autosplit is run again. 351# See AutoSplit.pm. 352package $this_package; 353 354#line $lineno "$filename (autosplit into $path)" 355EOT 356 print $out @cache; 357 @cache = (); 358 $caching = 0; 359 } 360 if($caching) { 361 push(@cache, $_) if @cache || /\S/; 362 } else { 363 print $out $_; 364 } 365 if(/^\}/) { 366 if($caching) { 367 print $out @cache; 368 @cache = (); 369 } 370 print $out "\n"; 371 $caching = 1; 372 } 373 $last_package = $this_package if defined $this_package; 374 } 375 if ($subname) { 376 print $out @cache,"1;\n# end of $last_package\::$subname\n"; 377 close($out); 378 } 379 close($in); 380 381 if (!$keep){ # don't keep any obsolete *.al files in the directory 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 387 # created. (The mixed case sub name won't match the all-lowercase 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) { 399 opendir(my $outdir,$dir); 400 foreach (sort readdir($outdir)){ 401 next unless /\.al\z/; 402 my($file) = catfile($dir, $_); 403 $file = lc $file if $Is83 or $Is_VMS; 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 } 410 closedir($outdir); 411 } 412 } 413 414 open(my $ts,">$al_idx_file") or 415 carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!"; 416 print $ts "# Index created by AutoSplit for $filename\n"; 417 print $ts "# (file acts as timestamp)\n"; 418 $last_package = ''; 419 for my $fqs (@subnames) { 420 my($subname) = $fqs; 421 $subname =~ s/.*:://; 422 print $ts "package $package{$fqs};\n" 423 unless $last_package eq $package{$fqs}; 424 print $ts "sub $subname $proto{$fqs};\n"; 425 $last_package = $package{$fqs}; 426 } 427 print $ts "1;\n"; 428 close($ts); 429 430 _check_unique($filename, $Maxlen, 1, @outfiles); 431 432 @outfiles; 433} 434 435sub _modpname ($) { 436 my($package) = @_; 437 my $modpname = $package; 438 if ($^O eq 'MSWin32') { 439 $modpname =~ s#::#\\#g; 440 } else { 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 450 } 451 $modpname; 452} 453 454sub _check_unique { 455 my($filename, $maxlen, $warn, @outfiles) = @_; 456 my(%notuniq) = (); 457 my(%shorts) = (); 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; 471 } 472 if (%notuniq && $warn){ 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 } 480 } 481 } 482} 483 4841; 485__END__ 486 487# test functions so AutoSplit.pm can be applied to itself: 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"; } 498package Yet::More::Attributes; 499sub test_a1 ($) : locked :locked { 1; } 500sub test_a2 : locked { 1; } 501