X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d6a466d771dbdc293e3f83b595b03cf44617cabb..1e9c9d75c412e4fc5365565439a8f9413cb3d90a:/lib/AutoSplit.pm?ds=sidebyside diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index 25e29c3..bf0f925 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -1,17 +1,16 @@ package AutoSplit; -use 5.005_64; +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); +use File::Spec::Functions qw(curdir catfile catdir); use strict; our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen, $CheckForAutoloader, $CheckModTime); -$VERSION = "1.0306"; +$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,17 +232,18 @@ 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/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); + next if /^\s*#/; # record last package name seen $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); @@ -255,9 +261,6 @@ sub autosplit_file { $def_package or die "Can't find 'package Name;' in $filename\n"; my($modpname) = _modpname($def_package); - if ($Is_VMS) { - $modpname = VMS::Filespec::unixify($modpname); # may have dirs - } # this _has_ to match so we have a reasonable timestamp file die "Package $def_package ($modpname.pm) does not ". @@ -278,7 +281,7 @@ sub autosplit_file { } } - my($modnamedir) = catfile($autodir, $modpname); + my($modnamedir) = catdir($autodir, $modpname); print "AutoSplitting $filename ($modnamedir)\n" if $Verbose; @@ -299,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/; @@ -310,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 || ''; @@ -326,23 +331,24 @@ sub autosplit_file { push(@subnames, $fq_subname); my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); $modpname = _modpname($this_package); - my($modnamedir) = catfile($autodir, $modpname); + my($modnamedir) = catdir($autodir, $modpname); mkpath($modnamedir,0,0777); 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); @@ -435,9 +441,15 @@ sub _modpname ($) { if ($^O eq 'MSWin32') { $modpname =~ s#::#\\#g; } else { - while ($modpname =~ m#(.*?[^:])::([^:].*)#) { - $modpname = catfile($1, $2); - } + my @modpnames = (); + while ($modpname =~ m#(.*?[^:])::([^:].*)#) { + push @modpnames, $1; + $modpname = $2; + } + $modpname = catfile(@modpnames, $modpname); + } + if ($Is_VMS) { + $modpname = VMS::Filespec::unixify($modpname); # may have dirs } $modpname; }