| 1 | package AutoSplit; |
| 2 | |
| 3 | use Exporter (); |
| 4 | use Config qw(%Config); |
| 5 | use File::Basename (); |
| 6 | use File::Path qw(mkpath); |
| 7 | use File::Spec::Functions qw(curdir catfile catdir); |
| 8 | use strict; |
| 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<autosplit> 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<autosplit.ix>. 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<autosplit> 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<autosplit> to check the module |
| 55 | currently being split to ensure that it includes a C<use> |
| 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<autosplit> is to check the modification time of the module |
| 64 | against that of the C<autosplit.ix> 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<autosplit> 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<autosplit_lib_modules> 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<lib> relative to the current directory. Each file is sent to the |
| 84 | autosplitter one at a time, to be split into the directory B<lib/auto>. |
| 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<AutoSplit> 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<AutoSplit> 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<AutoSplit> 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<AutoSplit> cannot locate |
| 126 | either the I<__END__> marker or a "package Name;"-style specification. |
| 127 | |
| 128 | C<AutoSplit> will also emit general diagnostics for inability to |
| 129 | create directories or files. |
| 130 | |
| 131 | =head1 AUTHOR |
| 132 | |
| 133 | C<AutoSplit> 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 <perl5-porters@perl.org> |
| 139 | |
| 140 | Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org> |
| 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> \( (?: [^()]++ | (?&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 | 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 | $keep = $Keep unless defined $keep; |
| 254 | $ckal = $CheckForAutoloader unless defined $ckal; |
| 255 | $ckmt = $CheckModTime unless defined $ckmt; |
| 256 | autosplit_file($file, $autodir, $keep, $ckal, $ckmt); |
| 257 | } |
| 258 | |
| 259 | sub carp{ |
| 260 | require Carp; |
| 261 | 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 | my(@modules) = @_; # list of Module names |
| 269 | local $_; # Avoid clobber. |
| 270 | while (defined($_ = shift @modules)) { |
| 271 | while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ |
| 272 | $_ = catfile($1, $2); |
| 273 | } |
| 274 | s|\\|/|g; # bug in ksh OS/2 |
| 275 | s#^lib/##s; # incase specified as lib/*.pm |
| 276 | my($lib) = catfile(curdir(), "lib"); |
| 277 | if ($Is_VMS) { # may need to convert VMS-style filespecs |
| 278 | $lib =~ s#^\[\]#.\/#; |
| 279 | } |
| 280 | s#^$lib\W+##s; # incase specified as ./lib/*.pm |
| 281 | if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs |
| 282 | my ($dir,$name) = (/(.*])(.*)/s); |
| 283 | $dir =~ s/.*lib[\.\]]//s; |
| 284 | $dir =~ s#[\.\]]#/#g; |
| 285 | $_ = $dir . $name; |
| 286 | } |
| 287 | autosplit_file(catfile($lib, $_), catfile($lib, "auto"), |
| 288 | $Keep, $CheckForAutoloader, $CheckModTime); |
| 289 | } |
| 290 | 0; |
| 291 | } |
| 292 | |
| 293 | |
| 294 | # private functions |
| 295 | |
| 296 | my $self_mod_time = (stat __FILE__)[9]; |
| 297 | |
| 298 | sub autosplit_file { |
| 299 | my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) |
| 300 | = @_; |
| 301 | my(@outfiles); |
| 302 | local($_); |
| 303 | local($/) = "\n"; |
| 304 | |
| 305 | # where to write output files |
| 306 | $autodir ||= catfile(curdir(), "lib", "auto"); |
| 307 | if ($Is_VMS) { |
| 308 | ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||; |
| 309 | $filename = VMS::Filespec::unixify($filename); # may have dirs |
| 310 | } |
| 311 | unless (-d $autodir){ |
| 312 | 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 | print "Warning: AutoSplit had to create top-level " . |
| 318 | "$autodir unexpectedly.\n"; |
| 319 | } |
| 320 | |
| 321 | # allow just a package name to be used |
| 322 | $filename .= ".pm" unless ($filename =~ m/\.pm\z/); |
| 323 | |
| 324 | open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n"; |
| 325 | my($pm_mod_time) = (stat($filename))[9]; |
| 326 | my($autoloader_seen) = 0; |
| 327 | my($in_pod) = 0; |
| 328 | my($def_package,$last_package,$this_package,$fnr); |
| 329 | while (<$in>) { |
| 330 | # Skip pod text. |
| 331 | $fnr++; |
| 332 | $in_pod = 1 if /^=\w/; |
| 333 | $in_pod = 0 if /^=cut/; |
| 334 | next if ($in_pod || /^=cut/); |
| 335 | next if /^\s*#/; |
| 336 | |
| 337 | # record last package name seen |
| 338 | $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); |
| 339 | ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/; |
| 340 | ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; |
| 341 | last if /^__END__/; |
| 342 | } |
| 343 | if ($check_for_autoloader && !$autoloader_seen){ |
| 344 | print "AutoSplit skipped $filename: no AutoLoader used\n" |
| 345 | if ($Verbose>=2); |
| 346 | return 0; |
| 347 | } |
| 348 | $_ or die "Can't find __END__ in $filename\n"; |
| 349 | |
| 350 | $def_package or die "Can't find 'package Name;' in $filename\n"; |
| 351 | |
| 352 | my($modpname) = _modpname($def_package); |
| 353 | |
| 354 | # this _has_ to match so we have a reasonable timestamp file |
| 355 | die "Package $def_package ($modpname.pm) does not ". |
| 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 | my($al_idx_file) = catfile($autodir, $modpname, $IndexFile); |
| 362 | |
| 363 | if ($check_mod_time){ |
| 364 | my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; |
| 365 | if ($al_ts_time >= $pm_mod_time and |
| 366 | $al_ts_time >= $self_mod_time){ |
| 367 | print "AutoSplit skipped ($al_idx_file newer than $filename)\n" |
| 368 | if ($Verbose >= 2); |
| 369 | return undef; # one undef, not a list |
| 370 | } |
| 371 | } |
| 372 | |
| 373 | my($modnamedir) = catdir($autodir, $modpname); |
| 374 | print "AutoSplitting $filename ($modnamedir)\n" |
| 375 | if $Verbose; |
| 376 | |
| 377 | unless (-d $modnamedir){ |
| 378 | 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 | my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames |
| 389 | |
| 390 | my(@subnames, $subname, %proto, %package); |
| 391 | my @cache = (); |
| 392 | my $caching = 1; |
| 393 | $last_package = ''; |
| 394 | my $out; |
| 395 | while (<$in>) { |
| 396 | $fnr++; |
| 397 | $in_pod = 1 if /^=\w/; |
| 398 | $in_pod = 0 if /^=cut/; |
| 399 | 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 | if (/^package\s+([\w:]+)\s*;/) { |
| 404 | $this_package = $def_package = $1; |
| 405 | } |
| 406 | |
| 407 | if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) { |
| 408 | print $out "# end of $last_package\::$subname\n1;\n" |
| 409 | if $last_package; |
| 410 | $subname = $1; |
| 411 | my $proto = $2 || ''; |
| 412 | if ($subname =~ s/(.*):://){ |
| 413 | $this_package = $1; |
| 414 | } else { |
| 415 | $this_package = $def_package; |
| 416 | } |
| 417 | my $fq_subname = "$this_package\::$subname"; |
| 418 | $package{$fq_subname} = $this_package; |
| 419 | $proto{$fq_subname} = $proto; |
| 420 | push(@subnames, $fq_subname); |
| 421 | my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); |
| 422 | $modpname = _modpname($this_package); |
| 423 | my($modnamedir) = catdir($autodir, $modpname); |
| 424 | mkpath($modnamedir,0,0777); |
| 425 | my($lpath) = catfile($modnamedir, "$lname.al"); |
| 426 | my($spath) = catfile($modnamedir, "$sname.al"); |
| 427 | my $path; |
| 428 | |
| 429 | if (!$Is83 and open($out, ">$lpath")){ |
| 430 | $path=$lpath; |
| 431 | print " writing $lpath\n" if ($Verbose>=2); |
| 432 | } else { |
| 433 | open($out, ">$spath") or die "Can't create $spath: $!\n"; |
| 434 | $path=$spath; |
| 435 | print " writing $spath (with truncated name)\n" |
| 436 | if ($Verbose>=1); |
| 437 | } |
| 438 | push(@outfiles, $path); |
| 439 | my $lineno = $fnr - @cache; |
| 440 | print $out <<EOT; |
| 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 | print $out @cache; |
| 449 | @cache = (); |
| 450 | $caching = 0; |
| 451 | } |
| 452 | if($caching) { |
| 453 | push(@cache, $_) if @cache || /\S/; |
| 454 | } else { |
| 455 | print $out $_; |
| 456 | } |
| 457 | if(/^\}/) { |
| 458 | if($caching) { |
| 459 | print $out @cache; |
| 460 | @cache = (); |
| 461 | } |
| 462 | print $out "\n"; |
| 463 | $caching = 1; |
| 464 | } |
| 465 | $last_package = $this_package if defined $this_package; |
| 466 | } |
| 467 | if ($subname) { |
| 468 | print $out @cache,"1;\n# end of $last_package\::$subname\n"; |
| 469 | close($out); |
| 470 | } |
| 471 | close($in); |
| 472 | |
| 473 | if (!$keep){ # don't keep any obsolete *.al files in the directory |
| 474 | 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 | if ($Is_VMS or $Is83) { |
| 482 | %outfiles = map {lc($_) => lc($_) } @outfiles; |
| 483 | } else { |
| 484 | @outfiles{@outfiles} = @outfiles; |
| 485 | } |
| 486 | my(%outdirs,@outdirs); |
| 487 | for (@outfiles) { |
| 488 | $outdirs{File::Basename::dirname($_)}||=1; |
| 489 | } |
| 490 | for my $dir (keys %outdirs) { |
| 491 | opendir(my $outdir,$dir); |
| 492 | foreach (sort readdir($outdir)){ |
| 493 | next unless /\.al\z/; |
| 494 | my($file) = catfile($dir, $_); |
| 495 | $file = lc $file if $Is83 or $Is_VMS; |
| 496 | next if $outfiles{$file}; |
| 497 | print " deleting $file\n" if ($Verbose>=2); |
| 498 | my($deleted,$thistime); # catch all versions on VMS |
| 499 | do { $deleted += ($thistime = unlink $file) } while ($thistime); |
| 500 | carp ("Unable to delete $file: $!") unless $deleted; |
| 501 | } |
| 502 | closedir($outdir); |
| 503 | } |
| 504 | } |
| 505 | |
| 506 | open(my $ts,">$al_idx_file") or |
| 507 | carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!"); |
| 508 | print $ts "# Index created by AutoSplit for $filename\n"; |
| 509 | print $ts "# (file acts as timestamp)\n"; |
| 510 | $last_package = ''; |
| 511 | for my $fqs (@subnames) { |
| 512 | my($subname) = $fqs; |
| 513 | $subname =~ s/.*:://; |
| 514 | print $ts "package $package{$fqs};\n" |
| 515 | unless $last_package eq $package{$fqs}; |
| 516 | print $ts "sub $subname $proto{$fqs};\n"; |
| 517 | $last_package = $package{$fqs}; |
| 518 | } |
| 519 | print $ts "1;\n"; |
| 520 | close($ts); |
| 521 | |
| 522 | _check_unique($filename, $Maxlen, 1, @outfiles); |
| 523 | |
| 524 | @outfiles; |
| 525 | } |
| 526 | |
| 527 | sub _modpname ($) { |
| 528 | my($package) = @_; |
| 529 | my $modpname = $package; |
| 530 | if ($^O eq 'MSWin32') { |
| 531 | $modpname =~ s#::#\\#g; |
| 532 | } else { |
| 533 | my @modpnames = (); |
| 534 | while ($modpname =~ m#(.*?[^:])::([^:].*)#) { |
| 535 | push @modpnames, $1; |
| 536 | $modpname = $2; |
| 537 | } |
| 538 | $modpname = catfile(@modpnames, $modpname); |
| 539 | } |
| 540 | if ($Is_VMS) { |
| 541 | $modpname = VMS::Filespec::unixify($modpname); # may have dirs |
| 542 | } |
| 543 | $modpname; |
| 544 | } |
| 545 | |
| 546 | sub _check_unique { |
| 547 | my($filename, $maxlen, $warn, @outfiles) = @_; |
| 548 | my(%notuniq) = (); |
| 549 | my(%shorts) = (); |
| 550 | my(@toolong) = grep( |
| 551 | length(File::Basename::basename($_)) |
| 552 | > $maxlen, |
| 553 | @outfiles |
| 554 | ); |
| 555 | |
| 556 | foreach (@toolong){ |
| 557 | my($dir) = File::Basename::dirname($_); |
| 558 | my($file) = File::Basename::basename($_); |
| 559 | my($trunc) = substr($file,0,$maxlen); |
| 560 | $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc}; |
| 561 | $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ? |
| 562 | "$shorts{$dir}{$trunc}, $file" : $file; |
| 563 | } |
| 564 | if (%notuniq && $warn){ |
| 565 | print "$filename: some names are not unique when " . |
| 566 | "truncated to $maxlen characters:\n"; |
| 567 | foreach my $dir (sort keys %notuniq){ |
| 568 | print " directory $dir:\n"; |
| 569 | foreach my $trunc (sort keys %{$notuniq{$dir}}) { |
| 570 | print " $shorts{$dir}{$trunc} truncate to $trunc\n"; |
| 571 | } |
| 572 | } |
| 573 | } |
| 574 | } |
| 575 | |
| 576 | 1; |
| 577 | __END__ |
| 578 | |
| 579 | # test functions so AutoSplit.pm can be applied to itself: |
| 580 | sub test1 ($) { "test 1\n"; } |
| 581 | sub test2 ($$) { "test 2\n"; } |
| 582 | sub test3 ($$$) { "test 3\n"; } |
| 583 | sub testtesttesttest4_1 { "test 4\n"; } |
| 584 | sub testtesttesttest4_2 { "duplicate test 4\n"; } |
| 585 | sub Just::Another::test5 { "another test 5\n"; } |
| 586 | sub test6 { return join ":", __FILE__,__LINE__; } |
| 587 | package Yet::Another::AutoSplit; |
| 588 | sub testtesttesttest4_1 ($) { "another test 4\n"; } |
| 589 | sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; } |
| 590 | package Yet::More::Attributes; |
| 591 | sub test_a1 ($) : locked :locked { 1; } |
| 592 | sub test_a2 : locked { 1; } |