| 1 |
root |
1.1 |
package AutoSplit; |
| 2 |
|
|
|
| 3 |
|
|
use 5.006_001; |
| 4 |
|
|
use Exporter (); |
| 5 |
|
|
use Config qw(%Config); |
| 6 |
|
|
use Carp qw(carp); |
| 7 |
|
|
use File::Basename (); |
| 8 |
|
|
use File::Path qw(mkpath); |
| 9 |
|
|
use File::Spec::Functions qw(curdir catfile catdir); |
| 10 |
|
|
use strict; |
| 11 |
|
|
our($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 |
|
|
|
| 21 |
|
|
AutoSplit - 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 |
|
|
|
| 31 |
|
|
This function will split up your program into files that the AutoLoader |
| 32 |
|
|
module can handle. It is used by both the standard perl libraries and by |
| 33 |
|
|
the MakeMaker utility, to automatically configure libraries for autoloading. |
| 34 |
|
|
|
| 35 |
|
|
The C<autosplit> interface splits the specified file into a hierarchy |
| 36 |
|
|
rooted at the directory C<$dir>. It creates directories as needed to reflect |
| 37 |
|
|
class hierarchy, and creates the file F<autosplit.ix>. This file acts as |
| 38 |
|
|
both forward declaration of all package routines, and as timestamp for the |
| 39 |
|
|
last update of the hierarchy. |
| 40 |
|
|
|
| 41 |
|
|
The remaining three arguments to C<autosplit> govern other options to |
| 42 |
|
|
the autosplitter. |
| 43 |
|
|
|
| 44 |
|
|
=over 2 |
| 45 |
|
|
|
| 46 |
|
|
=item $keep |
| 47 |
|
|
|
| 48 |
|
|
If the third argument, I<$keep>, is false, then any |
| 49 |
|
|
pre-existing C<*.al> files in the autoload directory are removed if |
| 50 |
|
|
they are no longer part of the module (obsoleted functions). |
| 51 |
|
|
$keep defaults to 0. |
| 52 |
|
|
|
| 53 |
|
|
=item $check |
| 54 |
|
|
|
| 55 |
|
|
The |
| 56 |
|
|
fourth argument, I<$check>, instructs C<autosplit> to check the module |
| 57 |
|
|
currently being split to ensure that it includes a C<use> |
| 58 |
|
|
specification for the AutoLoader module, and skips the module if |
| 59 |
|
|
AutoLoader is not detected. |
| 60 |
|
|
$check defaults to 1. |
| 61 |
|
|
|
| 62 |
|
|
=item $modtime |
| 63 |
|
|
|
| 64 |
|
|
Lastly, the I<$modtime> argument specifies |
| 65 |
|
|
that C<autosplit> is to check the modification time of the module |
| 66 |
|
|
against that of the C<autosplit.ix> file, and only split the module if |
| 67 |
|
|
it is newer. |
| 68 |
|
|
$modtime defaults to 1. |
| 69 |
|
|
|
| 70 |
|
|
=back |
| 71 |
|
|
|
| 72 |
|
|
Typical use of AutoSplit in the perl MakeMaker utility is via the command-line |
| 73 |
|
|
with: |
| 74 |
|
|
|
| 75 |
|
|
perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)' |
| 76 |
|
|
|
| 77 |
|
|
Defined as a Make macro, it is invoked with file and directory arguments; |
| 78 |
|
|
C<autosplit> will split the specified file into the specified directory and |
| 79 |
|
|
delete obsolete C<.al> files, after checking first that the module does use |
| 80 |
|
|
the AutoLoader, and ensuring that the module is not already currently split |
| 81 |
|
|
in its current form (the modtime test). |
| 82 |
|
|
|
| 83 |
|
|
The C<autosplit_lib_modules> form is used in the building of perl. It takes |
| 84 |
|
|
as input a list of files (modules) that are assumed to reside in a directory |
| 85 |
|
|
B<lib> relative to the current directory. Each file is sent to the |
| 86 |
|
|
autosplitter one at a time, to be split into the directory B<lib/auto>. |
| 87 |
|
|
|
| 88 |
|
|
In both usages of the autosplitter, only subroutines defined following the |
| 89 |
|
|
perl I<__END__> token are split out into separate files. Some |
| 90 |
|
|
routines may be placed prior to this marker to force their immediate loading |
| 91 |
|
|
and parsing. |
| 92 |
|
|
|
| 93 |
|
|
=head2 Multiple packages |
| 94 |
|
|
|
| 95 |
|
|
As of version 1.01 of the AutoSplit module it is possible to have |
| 96 |
|
|
multiple packages within a single file. Both of the following cases |
| 97 |
|
|
are 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 |
|
|
|
| 115 |
|
|
C<AutoSplit> will inform the user if it is necessary to create the |
| 116 |
|
|
top-level directory specified in the invocation. It is preferred that |
| 117 |
|
|
the script or installation process that invokes C<AutoSplit> have |
| 118 |
|
|
created the full directory path ahead of time. This warning may |
| 119 |
|
|
indicate that the module is being split into an incorrect path. |
| 120 |
|
|
|
| 121 |
|
|
C<AutoSplit> will warn the user of all subroutines whose name causes |
| 122 |
|
|
potential file naming conflicts on machines with drastically limited |
| 123 |
|
|
(8 characters or less) file name length. Since the subroutine name is |
| 124 |
|
|
used as the file name, these warnings can aid in portability to such |
| 125 |
|
|
systems. |
| 126 |
|
|
|
| 127 |
|
|
Warnings are issued and the file skipped if C<AutoSplit> cannot locate |
| 128 |
|
|
either the I<__END__> marker or a "package Name;"-style specification. |
| 129 |
|
|
|
| 130 |
|
|
C<AutoSplit> will also emit general diagnostics for inability to |
| 131 |
|
|
create 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 |
|
|
|
| 142 |
|
|
my $IndexFile = "autosplit.ix"; # file also serves as timestamp |
| 143 |
|
|
my $maxflen = 255; |
| 144 |
|
|
$maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; |
| 145 |
|
|
if (defined (&Dos::UseLFN)) { |
| 146 |
|
|
$maxflen = Dos::UseLFN() ? 255 : 11; |
| 147 |
|
|
} |
| 148 |
|
|
my $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}) ) |
| 153 |
|
|
our $nested; |
| 154 |
|
|
$nested = qr{ \( (?: (?> [^()]+ ) | (??{ $nested }) )* \) }x; |
| 155 |
|
|
our $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x; |
| 156 |
|
|
our $attr_list = qr{ \s* : \s* (?: $one_attr )* }x; |
| 157 |
|
|
|
| 158 |
|
|
|
| 159 |
|
|
|
| 160 |
|
|
sub 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 |
|
|
|
| 175 |
|
|
sub 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 |
|
|
|
| 204 |
|
|
my $self_mod_time = (stat __FILE__)[9]; |
| 205 |
|
|
|
| 206 |
|
|
sub 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. |
| 352 |
|
|
package $this_package; |
| 353 |
|
|
|
| 354 |
|
|
#line $lineno "$filename (autosplit into $path)" |
| 355 |
|
|
EOT |
| 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 |
|
|
|
| 435 |
|
|
sub _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 |
|
|
|
| 454 |
|
|
sub _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 |
|
|
|
| 484 |
|
|
1; |
| 485 |
|
|
__END__ |
| 486 |
|
|
|
| 487 |
|
|
# test functions so AutoSplit.pm can be applied to itself: |
| 488 |
|
|
sub test1 ($) { "test 1\n"; } |
| 489 |
|
|
sub test2 ($$) { "test 2\n"; } |
| 490 |
|
|
sub test3 ($$$) { "test 3\n"; } |
| 491 |
|
|
sub testtesttesttest4_1 { "test 4\n"; } |
| 492 |
|
|
sub testtesttesttest4_2 { "duplicate test 4\n"; } |
| 493 |
|
|
sub Just::Another::test5 { "another test 5\n"; } |
| 494 |
|
|
sub test6 { return join ":", __FILE__,__LINE__; } |
| 495 |
|
|
package Yet::Another::AutoSplit; |
| 496 |
|
|
sub testtesttesttest4_1 ($) { "another test 4\n"; } |
| 497 |
|
|
sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; } |
| 498 |
|
|
package Yet::More::Attributes; |
| 499 |
|
|
sub test_a1 ($) : locked :locked { 1; } |
| 500 |
|
|
sub test_a2 : locked { 1; } |
