X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b117983900e00fec1a326438505f92cf9183d038..50edf520be9fa4c0e7982006bec3a6939b2f61a7:/lib/AutoSplit.pm diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index 8640576..a7da1ac 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -1,17 +1,15 @@ package AutoSplit; -use 5.005_64; 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.0305"; +$VERSION = "1.05"; @ISA = qw(Exporter); @EXPORT = qw(&autosplit &autosplit_lib_modules); @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); @@ -54,7 +52,7 @@ $keep defaults to 0. The fourth argument, I<$check>, instructs C to check the module -currently being split to ensure that it does include a C +currently being split to ensure that it includes a C specification for the AutoLoader module, and skips the module if AutoLoader is not detected. $check defaults to 1. @@ -130,6 +128,75 @@ either the I<__END__> marker or a "package Name;"-style specification. C will also emit general diagnostics for inability to create directories or files. +=head1 AUTHOR + +C is maintained by the perl5-porters. Please direct +any questions to the canonical mailing list. Anything that +is applicable to the CPAN release can be sent to its maintainer, +though. + +Author and Maintainer: The Perl5-Porters + +Maintainer of the CPAN release: Steffen Mueller + +=head1 COPYRIGHT AND LICENSE + +This package has been part of the perl core since the first release +of perl5. It has been released separately to CPAN so older installations +can benefit from bug fixes. + +This package has the same copyright and license as the perl core: + + Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, + 2000, 2001, 2002, 2003, 2004, 2005, 2006 by Larry Wall and others + + All rights reserved. + + This program is free software; you can redistribute it and/or modify + it under the terms of either: + + a) the GNU General Public License as published by the Free + Software Foundation; either version 1, or (at your option) any + later version, or + + b) the "Artistic License" which comes with this Kit. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either + the GNU General Public License or the Artistic License for more details. + + You should have received a copy of the Artistic License with this + Kit, in the file named "Artistic". If not, I'll be glad to provide one. + + You should also have received a copy of the GNU General Public License + along with this program in the file named "Copying". If not, write to the + Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA + 02111-1307, USA or visit their web page on the internet at + http://www.gnu.org/copyleft/gpl.html. + + For those of you that choose to use the GNU General Public License, + my interpretation of the GNU General Public License is that no Perl + script falls under the terms of the GPL unless you explicitly put + said script under the terms of the GPL yourself. Furthermore, any + object code linked with perl does not automatically fall under the + terms of the GPL, provided such object code only adds definitions + of subroutines and variables, and does not otherwise impair the + resulting interpreter from executing any standard Perl script. I + consider linking in C subroutines in this manner to be the moral + equivalent of defining subroutines in the Perl language itself. You + may sell such an object file as proprietary provided that you provide + or offer to provide the Perl source, as specified by the GNU General + Public License. (This is merely an alternate way of specifying input + to the program.) You may also sell a binary produced by the dumping of + a running Perl script that belongs to you, provided that you provide or + offer to provide the Perl source as specified by the GPL. (The + fact that a Perl interpreter and your code are in the same binary file + is, in this case, a form of mere aggregation.) This is my interpretation + of the GPL. If you still have concerns or difficulties understanding + my intent, feel free to contact me. Of course, the Artistic License + spells all this out for your protection, so you may prefer to use that. + =cut # for portability warn about names longer than $maxlen @@ -147,13 +214,35 @@ if (defined (&Dos::UseLFN)) { } my $Is_VMS = ($^O eq 'VMS'); -# allow checking for valid ': attrlist' attachments -my $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; - - +# allow checking for valid ': attrlist' attachments. +# extra jugglery required to support both 5.8 and 5.9/5.10 features +# (support for 5.8 required for cross-compiling environments) + +my $attr_list = + $] >= 5.009005 ? + eval <<'__QR__' + qr{ + \s* : \s* + (?: + # one attribute + (?> # no backtrack + (?! \d) \w+ + (? \( (?: [^()]++ | (?&nested)++ )*+ \) ) ? + ) + (?: \s* : \s* | \s+ (?! :) ) + )* + }x +__QR__ + : + do { + # In pre-5.9.5 world we have to do dirty tricks. + # (we use 'our' rather than 'my' here, due to the rather complex and buggy + # behaviour of lexicals with qr// and (??{$lex}) ) + our $trick1; # yes, cannot our and assign at the same time. + $trick1 = qr{ \( (?: (?> [^()]+ ) | (??{ $trick1 }) )* \) }x; + our $trick2 = qr{ (?> (?! \d) \w+ (?:$trick1)? ) (?:\s*\:\s*|\s+(?!\:)) }x; + qr{ \s* : \s* (?: $trick2 )* }x; + }; sub autosplit{ my($file, $autodir, $keep, $ckal, $ckmt) = @_; @@ -166,15 +255,19 @@ 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)' ... -sub autosplit_lib_modules{ +sub autosplit_lib_modules { my(@modules) = @_; # list of Module names - - while(defined($_ = shift @modules)){ - while (m#(.*?[^:])::([^:].*)#) { # in case specified as ABC::XYZ + local $_; # Avoid clobber. + while (defined($_ = shift @modules)) { + while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ $_ = catfile($1, $2); } s|\\|/|g; # bug in ksh OS/2 @@ -199,6 +292,8 @@ sub autosplit_lib_modules{ # private functions +my $self_mod_time = (stat __FILE__)[9]; + sub autosplit_file { my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_; @@ -225,17 +320,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*;/); @@ -253,34 +349,32 @@ 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 ". "match filename $filename" unless ($filename =~ m/\Q$modpname.pm\E$/ or - ($^O eq 'dos') or ($^O eq 'MSWin32') or + ($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or $Is_VMS && $filename =~ m/$modpname.pm/i); - my($al_idx_file) = "$autodir/$modpname/$IndexFile"; + my($al_idx_file) = catfile($autodir, $modpname, $IndexFile); if ($check_mod_time){ my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; - if ($al_ts_time >= $pm_mod_time){ + if ($al_ts_time >= $pm_mod_time and + $al_ts_time >= $self_mod_time){ print "AutoSplit skipped ($al_idx_file newer than $filename)\n" if ($Verbose >= 2); return undef; # one undef, not a list } } - my($modnamedir) = catfile($autodir, $modpname); + my($modnamedir) = catdir($autodir, $modpname); print "AutoSplitting $filename ($modnamedir)\n" if $Verbose; - unless (-d "$modnamedir"){ - mkpath("$modnamedir",0,0777); + unless (-d $modnamedir){ + mkpath($modnamedir,0,0777); } # We must try to deal with some SVR3 systems with a limit of 14 @@ -296,7 +390,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/; @@ -307,8 +402,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 || ''; @@ -323,53 +419,55 @@ 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); - mkpath("$modnamedir",0,0777); + 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); - 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); @@ -431,9 +529,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; }