X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FAutoSplit.pm;h=bf0f9256c822b6a603abce87ee6068ea0708bffc;hb=0740f80f71de6af2dd0e3c3aecddec0fc42f34f0;hp=3c45d9211320ad81b050ce1d3d9ae34878c96fe2;hpb=fe169e074ced6c4ea9171b838d3697595aa1a180;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index 3c45d92..bf0f925 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -3,7 +3,6 @@ package AutoSplit; use 5.006_001; use Exporter (); use Config qw(%Config); -use Carp qw(carp); use File::Basename (); use File::Path qw(mkpath); use File::Spec::Functions qw(curdir catfile catdir); @@ -11,7 +10,7 @@ use strict; our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen, $CheckForAutoloader, $CheckModTime); -$VERSION = "1.0307"; +$VERSION = "1.04_01"; @ISA = qw(Exporter); @EXPORT = qw(&autosplit &autosplit_lib_modules); @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); @@ -148,10 +147,12 @@ if (defined (&Dos::UseLFN)) { my $Is_VMS = ($^O eq 'VMS'); # allow checking for valid ': attrlist' attachments -my $nested; +# (we use 'our' rather than 'my' here, due to the rather complex and buggy +# behaviour of lexicals with qr// and (??{$lex}) ) +our $nested; $nested = qr{ \( (?: (?> [^()]+ ) | (??{ $nested }) )* \) }x; -my $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x; -my $attr_list = qr{ \s* : \s* (?: $one_attr )* }x; +our $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x; +our $attr_list = qr{ \s* : \s* (?: $one_attr )* }x; @@ -166,6 +167,10 @@ sub autosplit{ autosplit_file($file, $autodir, $keep, $ckal, $ckmt); } +sub carp{ + require Carp; + goto &Carp::carp; +} # This function is used during perl building/installation # ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ... @@ -227,12 +232,12 @@ sub autosplit_file { # allow just a package name to be used $filename .= ".pm" unless ($filename =~ m/\.pm\z/); - open(IN, "<$filename") or die "AutoSplit: Can't open $filename: $!\n"; + open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n"; my($pm_mod_time) = (stat($filename))[9]; my($autoloader_seen) = 0; my($in_pod) = 0; my($def_package,$last_package,$this_package,$fnr); - while () { + while (<$in>) { # Skip pod text. $fnr++; $in_pod = 1 if /^=\w/; @@ -297,7 +302,8 @@ sub autosplit_file { my @cache = (); my $caching = 1; $last_package = ''; - while () { + my $out; + while (<$in>) { $fnr++; $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; @@ -308,8 +314,9 @@ sub autosplit_file { if (/^package\s+([\w:]+)\s*;/) { $this_package = $def_package = $1; } + if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) { - print OUT "# end of $last_package\::$subname\n1;\n" + print $out "# end of $last_package\::$subname\n1;\n" if $last_package; $subname = $1; my $proto = $2 || ''; @@ -329,18 +336,19 @@ sub autosplit_file { my($lpath) = catfile($modnamedir, "$lname.al"); my($spath) = catfile($modnamedir, "$sname.al"); my $path; - if (!$Is83 and open(OUT, ">$lpath")){ + + if (!$Is83 and open($out, ">$lpath")){ $path=$lpath; print " writing $lpath\n" if ($Verbose>=2); } else { - open(OUT, ">$spath") or die "Can't create $spath: $!\n"; + open($out, ">$spath") or die "Can't create $spath: $!\n"; $path=$spath; print " writing $spath (with truncated name)\n" if ($Verbose>=1); } push(@outfiles, $path); my $lineno = $fnr - @cache; - print OUT <=2); my($deleted,$thistime); # catch all versions on VMS do { $deleted += ($thistime = unlink $file) } while ($thistime); - carp "Unable to delete $file: $!" unless $deleted; + carp ("Unable to delete $file: $!") unless $deleted; } - closedir(OUTDIR); + closedir($outdir); } } - open(TS,">$al_idx_file") or - carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!"; - print TS "# Index created by AutoSplit for $filename\n"; - print TS "# (file acts as timestamp)\n"; + open(my $ts,">$al_idx_file") or + carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!"); + print $ts "# Index created by AutoSplit for $filename\n"; + print $ts "# (file acts as timestamp)\n"; $last_package = ''; for my $fqs (@subnames) { my($subname) = $fqs; $subname =~ s/.*:://; - print TS "package $package{$fqs};\n" + print $ts "package $package{$fqs};\n" unless $last_package eq $package{$fqs}; - print TS "sub $subname $proto{$fqs};\n"; + print $ts "sub $subname $proto{$fqs};\n"; $last_package = $package{$fqs}; } - print TS "1;\n"; - close(TS); + print $ts "1;\n"; + close($ts); _check_unique($filename, $Maxlen, 1, @outfiles);