From: Gurusamy Sarathy Date: Sat, 16 May 1998 21:04:04 +0000 (+0000) Subject: [win32] merge change#985 from maintbranch X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4e6ea2c3b30d1ef2a7f2c68db5d82351f13b502f;p=p5sagit%2Fp5-mst-13.2.git [win32] merge change#985 from maintbranch p4raw-link: @985 on //depot/maint-5.004/perl: cb99a88456c6181881501e9f4881bc3d3d3e919e p4raw-id: //depot/win32/perl@1002 --- diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index df54f15..471499a 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -1,12 +1,17 @@ package AutoSplit; -require 5.000; -require Exporter; - -use Config; -use Carp; +use Exporter (); +use Config qw(%Config); +use Carp qw(carp); +use File::Basename (); use File::Path qw(mkpath); +use strict; +use vars qw( + $VERSION @ISA @EXPORT @EXPORT_OK + $Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime + ); +$VERSION = "1.0302"; @ISA = qw(Exporter); @EXPORT = qw(&autosplit &autosplit_lib_modules); @EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); @@ -17,13 +22,9 @@ AutoSplit - split a package for autoloading =head1 SYNOPSIS - perl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ... - - use AutoSplit; autosplit($file, $dir, $keep, $check, $modtime); - -for perl versions 5.002 and later: + autosplit($file, $dir, $keep, $check, $modtime); - perl -MAutoSplit -e 'autosplit($ARGV[0], $ARGV[1], $k, $chk, $modtime)' ... + autosplit_lib_modules(@modules); =head1 DESCRIPTION @@ -37,16 +38,36 @@ class hierarchy, and creates the file F. This file acts as both forward declaration of all package routines, and as timestamp for the last update of the hierarchy. -The remaining three arguments to C govern other options to the -autosplitter. If the third argument, I<$keep>, is false, then any pre-existing -C<*.al> files in the autoload directory are removed if they are no longer -part of the module (obsoleted functions). The fourth argument, I<$check>, -instructs C to check the module currently being split to ensure -that it does include a C specification for the AutoLoader module, and -skips the module if AutoLoader is not detected. Lastly, the I<$modtime> -argument specifies that C is to check the modification time of the -module against that of the C file, and only split the module -if it is newer. +The remaining three arguments to C govern other options to +the autosplitter. + +=over 2 + +=item $keep + +If the third argument, I<$keep>, is false, then any +pre-existing C<*.al> files in the autoload directory are removed if +they are no longer part of the module (obsoleted functions). +$keep defaults to 0. + +=item $check + +The +fourth argument, I<$check>, instructs C to check the module +currently being split to ensure that it does include a C +specification for the AutoLoader module, and skips the module if +AutoLoader is not detected. +$check defaults to 1. + +=item $modtime + +Lastly, the I<$modtime> argument specifies +that C is to check the modification time of the module +against that of the C file, and only split the module if +it is newer. +$modtime defaults to 1. + +=back Typical use of AutoSplit in the perl MakeMaker utility is via the command-line with: @@ -65,33 +86,49 @@ B relative to the current directory. Each file is sent to the autosplitter one at a time, to be split into the directory B. In both usages of the autosplitter, only subroutines defined following the -perl special marker I<__END__> are split out into separate files. Some +perl I<__END__> token are split out into separate files. Some routines may be placed prior to this marker to force their immediate loading and parsing. -=head1 CAVEATS +=head2 Multiple packages + +As of version 1.01 of the AutoSplit module it is possible to have +multiple packages within a single file. Both of the following cases +are supported: + + package NAME; + __END__ + sub AAA { ... } + package NAME::option1; + sub BBB { ... } + package NAME::option2; + sub BBB { ... } -Currently, C cannot handle multiple package specifications -within one file. + package NAME; + __END__ + sub AAA { ... } + sub NAME::option1::BBB { ... } + sub NAME::option2::BBB { ... } =head1 DIAGNOSTICS -C will inform the user if it is necessary to create the top-level -directory specified in the invocation. It is preferred that the script or -installation process that invokes C have created the full directory -path ahead of time. This warning may indicate that the module is being split -into an incorrect path. +C will inform the user if it is necessary to create the +top-level directory specified in the invocation. It is preferred that +the script or installation process that invokes C have +created the full directory path ahead of time. This warning may +indicate that the module is being split into an incorrect path. -C will warn the user of all subroutines whose name causes potential -file naming conflicts on machines with drastically limited (8 characters or -less) file name length. Since the subroutine name is used as the file name, -these warnings can aid in portability to such systems. +C will warn the user of all subroutines whose name causes +potential file naming conflicts on machines with drastically limited +(8 characters or less) file name length. Since the subroutine name is +used as the file name, these warnings can aid in portability to such +systems. -Warnings are issued and the file skipped if C cannot locate either -the I<__END__> marker or a "package Name;"-style specification. +Warnings are issued and the file skipped if C cannot locate +either the I<__END__> marker or a "package Name;"-style specification. -C will also emit general diagnostics for inability to create -directories or files. +C will also emit general diagnostics for inability to +create directories or files. =cut @@ -102,21 +139,21 @@ $Keep = 0; $CheckForAutoloader = 1; $CheckModTime = 1; -$IndexFile = "autosplit.ix"; # file also serves as timestamp -$maxflen = 255; +my $IndexFile = "autosplit.ix"; # file also serves as timestamp +my $maxflen = 255; $maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; if (defined (&Dos::UseLFN)) { $maxflen = Dos::UseLFN() ? 255 : 11; } -$Is_VMS = ($^O eq 'VMS'); +my $Is_VMS = ($^O eq 'VMS'); sub autosplit{ - my($file, $autodir, $k, $ckal, $ckmt) = @_; + my($file, $autodir, $keep, $ckal, $ckmt) = @_; # $file - the perl source file to be split (after __END__) # $autodir - the ".../auto" dir below which to write split subs # Handle optional flags: - $keep = $Keep unless defined $k; + $keep = $Keep unless defined $keep; $ckal = $CheckForAutoloader unless defined $ckal; $ckmt = $CheckModTime unless defined $ckmt; autosplit_file($file, $autodir, $keep, $ckal, $ckmt); @@ -139,7 +176,8 @@ sub autosplit_lib_modules{ $dir =~ s#[\.\]]#/#g; $_ = $dir . $name; } - autosplit_file("lib/$_", "lib/auto", $Keep, $CheckForAutoloader, $CheckModTime); + autosplit_file("lib/$_", "lib/auto", + $Keep, $CheckForAutoloader, $CheckModTime); } 0; } @@ -147,60 +185,64 @@ sub autosplit_lib_modules{ # private functions -sub autosplit_file{ - my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_; - my(@names); +sub autosplit_file { + my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) + = @_; + my(@outfiles); local($_); + local($/) = "\n"; # where to write output files - $autodir = "lib/auto" unless $autodir; + $autodir ||= "lib/auto"; if ($Is_VMS) { - ($autodir = VMS::Filespec::unixpath($autodir)) =~ s{/$}{}; + ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/$||; $filename = VMS::Filespec::unixify($filename); # may have dirs } unless (-d $autodir){ mkpath($autodir,0,0755); - # We should never need to create the auto dir here. installperl - # (or similar) should have done it. Expecting it to exist is a valuable - # sanity check against autosplitting into some random directory by mistake. - print "Warning: AutoSplit had to create top-level $autodir unexpectedly.\n"; + # We should never need to create the auto dir + # here. installperl (or similar) should have done + # it. Expecting it to exist is a valuable sanity check against + # autosplitting into some random directory by mistake. + print "Warning: AutoSplit had to create top-level " . + "$autodir unexpectedly.\n"; } # allow just a package name to be used $filename .= ".pm" unless ($filename =~ m/\.pm$/); - open(IN, "<$filename") || die "AutoSplit: Can't open $filename: $!\n"; + open(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 () { # Skip pod text. + $fnr++; $in_pod = 1 if /^=/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # record last package name seen - $package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); + $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/; ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; last if /^__END__/; } if ($check_for_autoloader && !$autoloader_seen){ - print "AutoSplit skipped $filename: no AutoLoader used\n" if ($Verbose>=2); - return 0 + print "AutoSplit skipped $filename: no AutoLoader used\n" + if ($Verbose>=2); + return 0; } $_ or die "Can't find __END__ in $filename\n"; - $package or die "Can't find 'package Name;' in $filename\n"; + $def_package or die "Can't find 'package Name;' in $filename\n"; - my($modpname) = $package; - if ($^O eq 'MSWin32') { - $modpname =~ s#::#\\#g; - } else { - $modpname =~ s#::#/#g; - } + my($modpname) = _modpname($def_package); - die "Package $package ($modpname.pm) does not match filename $filename" + # 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 $Is_VMS && $filename =~ m/$modpname.pm/i); @@ -210,14 +252,13 @@ sub autosplit_file{ if ($check_mod_time){ my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; if ($al_ts_time >= $pm_mod_time){ - print "AutoSplit skipped ($al_idx_file newer that $filename)\n" + print "AutoSplit skipped ($al_idx_file newer than $filename)\n" if ($Verbose >= 2); return undef; # one undef, not a list } } - my($from) = ($Verbose>=2) ? "$filename => " : ""; - print "AutoSplitting $package ($from$autodir/$modpname)\n" + print "AutoSplitting $filename ($autodir/$modpname)\n" if $Verbose; unless (-d "$autodir/$modpname"){ @@ -231,69 +272,71 @@ sub autosplit_file{ # This is a problem because some systems silently truncate the file # names while others treat long file names as an error. - # We do not yet deal with multiple packages within one file. - # Ideally both of these styles should work. - # - # package NAME; - # __END__ - # sub AAA { ... } - # package NAME::option1; - # sub BBB { ... } - # package NAME::option2; - # sub BBB { ... } - # - # package NAME; - # __END__ - # sub AAA { ... } - # sub NAME::option1::BBB { ... } - # sub NAME::option2::BBB { ... } - # - # For now both of these produce warnings. - my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames - open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning - my(@subnames, %proto); + my(@subnames, $subname, %proto, %package); my @cache = (); my $caching = 1; + $last_package = ''; while () { - next if /^=\w/ .. /^=cut/; - if (/^package ([\w:]+)\s*;/) { - warn "package $1; in AutoSplit section ignored. Not currently supported."; + $fnr++; + $in_pod = 1 if /^=/; + $in_pod = 0 if /^=cut/; + next if ($in_pod || /^=cut/); + # the following (tempting) old coding gives big troubles if a + # cut is forgotten at EOF: + # next if /^=\w/ .. /^=cut/; + if (/^package\s+([\w:]+)\s*;/) { + $this_package = $def_package = $1; } if (/^sub\s+([\w:]+)(\s*\(.*?\))?/) { - print OUT "1;\n"; - my $subname = $1; - $proto{$1} = $2 || ''; - if ($subname =~ m/::/){ - warn "subs with package names not currently supported in AutoSplit section"; + print OUT "# end of $last_package\::$subname\n1;\n" + if $last_package; + $subname = $1; + my $proto = $2 || ''; + if ($subname =~ s/(.*):://){ + $this_package = $1; + } else { + $this_package = $def_package; } - push(@subnames, $subname); + my $fq_subname = "$this_package\::$subname"; + $package{$fq_subname} = $this_package; + $proto{$fq_subname} = $proto; + push(@subnames, $fq_subname); my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); + $modpname = _modpname($this_package); + mkpath("$autodir/$modpname",0,0777); my($lpath) = "$autodir/$modpname/$lname.al"; my($spath) = "$autodir/$modpname/$sname.al"; - unless(open(OUT, ">$lpath")){ - open(OUT, ">$spath") or die "Can't create $spath: $!\n"; - push(@names, $Is83 ? lc $sname : $sname); - print " writing $spath (with truncated name)\n" if ($Verbose>=1); - }else{ - push(@names, $Is83 ? lc substr ($lname,0,8) : $lname); + my $path; + 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"; + $path=$spath; + print " writing $spath (with truncated name)\n" + if ($Verbose>=1); } - print OUT "# NOTE: Derived from $filename. ", - "Changes made here will be lost.\n"; - print OUT "package $package;\n\n"; + 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; + my(%outfiles); + # @outfiles{@outfiles} = @outfiles; + # perl downcases all filenames on VMS (which upcases all filenames) so + # we'd better downcase the sub name list too, or subs with upper case + # letters in them will get their .al files deleted right after they're + # created. (The mixed case sub name wonn't match the all-lowercase + # filename, and so be cleaned up as a scrap file) + if ($Is_VMS or $Is83) { + %outfiles = map {lc($_) => lc($_) } @outfiles; + } else { + @outfiles{@outfiles} = @outfiles; + } + my(%outdirs,@outdirs); + for (@outfiles) { + $outdirs{File::Basename::dirname($_)}||=1; + } + for my $dir (keys %outdirs) { + opendir(OUTDIR,$dir); + foreach (sort readdir(OUTDIR)){ + next unless /\.al$/; + my($file) = "$dir/$_"; + $file = lc $file if $Is83; + next if $outfiles{$file}; + print " deleting $file\n" if ($Verbose>=2); + my($deleted,$thistime); # catch all versions on VMS + do { $deleted += ($thistime = unlink $file) } while ($thistime); + 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 (file acts as timestamp)\n"; - print TS "package $package;\n"; - print TS map("sub $_$proto{$_} ;\n", @subnames); + 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" + unless $last_package eq $package{$fqs}; + print TS "sub $subname $proto{$fqs};\n"; + $last_package = $package{$fqs}; + } print TS "1;\n"; close(TS); - check_unique($package, $Maxlen, 1, @names); + _check_unique($filename, $Maxlen, 1, @outfiles); - @names; + @outfiles; } +sub _modpname ($) { + my($package) = @_; + my $modpname = $package; + if ($^O eq 'MSWin32') { + $modpname =~ s#::#\\#g; + } else { + $modpname =~ s#::#/#g; + } + $modpname; +} -sub check_unique{ - my($module, $maxlen, $warn, @names) = @_; +sub _check_unique { + my($filename, $maxlen, $warn, @outfiles) = @_; my(%notuniq) = (); my(%shorts) = (); - my(@toolong) = grep(length > $maxlen, @names); - - foreach(@toolong){ - my($trunc) = substr($_,0,$maxlen); - $notuniq{$trunc}=1 if $shorts{$trunc}; - $shorts{$trunc} = ($shorts{$trunc}) ? "$shorts{$trunc}, $_" : $_; + my(@toolong) = grep( + length(File::Basename::basename($_)) + > $maxlen, + @outfiles + ); + + foreach (@toolong){ + my($dir) = File::Basename::dirname($_); + my($file) = File::Basename::basename($_); + my($trunc) = substr($file,0,$maxlen); + $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc}; + $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ? + "$shorts{$dir}{$trunc}, $file" : $file; } if (%notuniq && $warn){ - print "$module: some names are not unique when truncated to $maxlen characters:\n"; - foreach(keys %notuniq){ - print " $shorts{$_} truncate to $_\n"; + print "$filename: some names are not unique when " . + "truncated to $maxlen characters:\n"; + foreach my $dir (sort keys %notuniq){ + print " directory $dir:\n"; + foreach my $trunc (sort keys %{$notuniq{$dir}}) { + print " $shorts{$dir}{$trunc} truncate to $trunc\n"; + } } } - %notuniq; } 1; __END__ # test functions so AutoSplit.pm can be applied to itself: -sub test1{ "test 1\n"; } -sub test2{ "test 2\n"; } -sub test3{ "test 3\n"; } -sub test4{ "test 4\n"; } - - +sub test1 ($) { "test 1\n"; } +sub test2 ($$) { "test 2\n"; } +sub test3 ($$$) { "test 3\n"; } +sub testtesttesttest4_1 { "test 4\n"; } +sub testtesttesttest4_2 { "duplicate test 4\n"; } +sub Just::Another::test5 { "another test 5\n"; } +sub test6 { return join ":", __FILE__,__LINE__; } +package Yet::Another::AutoSplit; +sub testtesttesttest4_1 ($) { "another test 4\n"; } +sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; } diff --git a/lib/ExtUtils/Manifest.pm b/lib/ExtUtils/Manifest.pm index 8437346..5557089 100644 --- a/lib/ExtUtils/Manifest.pm +++ b/lib/ExtUtils/Manifest.pm @@ -242,7 +242,11 @@ sub ln { link($srcFile, $dstFile); local($_) = $dstFile; # chmod a+r,go-w+X (except "X" only applies to u=x) my $mode= 0444 | (stat)[2] & 0700; - chmod( $mode | ( $mode & 0100 ? 0111 : 0 ), $_ ); + if (! chmod( $mode | ( $mode & 0100 ? 0111 : 0 ), $_ )) { + unlink $dstFile; + return; + } + 1; } sub best { diff --git a/pp_ctl.c b/pp_ctl.c index 75cf077..55881de 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1041,29 +1041,33 @@ die_where(char *message) I32 gimme; SV **newsp; - if (in_eval & 4) { - SV **svp; - STRLEN klen = strlen(message); - - svp = hv_fetch(ERRHV, message, klen, TRUE); - if (svp) { - if (!SvIOK(*svp)) { - static char prefix[] = "\t(in cleanup) "; - SV *err = ERRSV; - sv_upgrade(*svp, SVt_IV); - (void)SvIOK_only(*svp); - if (!SvPOK(err)) - sv_setpv(err,""); - SvGROW(err, SvCUR(err)+sizeof(prefix)+klen); - sv_catpvn(err, prefix, sizeof(prefix)-1); - sv_catpvn(err, message, klen); + if (message) { + if (in_eval & 4) { + SV **svp; + STRLEN klen = strlen(message); + + svp = hv_fetch(ERRHV, message, klen, TRUE); + if (svp) { + if (!SvIOK(*svp)) { + static char prefix[] = "\t(in cleanup) "; + SV *err = ERRSV; + sv_upgrade(*svp, SVt_IV); + (void)SvIOK_only(*svp); + if (!SvPOK(err)) + sv_setpv(err,""); + SvGROW(err, SvCUR(err)+sizeof(prefix)+klen); + sv_catpvn(err, prefix, sizeof(prefix)-1); + sv_catpvn(err, message, klen); + } + sv_inc(*svp); } - sv_inc(*svp); } + else + sv_setpv(ERRSV, message); } else - sv_setpv(ERRSV, message); - + message = SvPVx(ERRSV, na); + while ((cxix = dopoptoeval(cxstack_ix)) < 0 && curstackinfo->si_prev) { dounwind(-1); POPSTACK(); diff --git a/pp_sys.c b/pp_sys.c index f4827bb..d00d162 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -290,10 +290,11 @@ PP(pp_warn) tmps = SvPV(TOPs, na); } if (!tmps || !*tmps) { - (void)SvUPGRADE(ERRSV, SVt_PV); - if (SvPOK(ERRSV) && SvCUR(ERRSV)) - sv_catpv(ERRSV, "\t...caught"); - tmps = SvPV(ERRSV, na); + SV *error = ERRSV; + (void)SvUPGRADE(error, SVt_PV); + if (SvPOK(error) && SvCUR(error)) + sv_catpv(error, "\t...caught"); + tmps = SvPV(error, na); } if (!tmps || !*tmps) tmps = "Warning: something's wrong"; @@ -305,6 +306,8 @@ PP(pp_die) { djSP; dMARK; char *tmps; + SV *tmpsv = Nullsv; + char *pat = "%s"; if (SP - MARK != 1) { dTARGET; do_join(TARG, &sv_no, MARK, SP); @@ -312,17 +315,26 @@ PP(pp_die) SP = MARK + 1; } else { - tmps = SvPV(TOPs, na); + tmpsv = TOPs; + tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, na); } if (!tmps || !*tmps) { - (void)SvUPGRADE(ERRSV, SVt_PV); - if (SvPOK(ERRSV) && SvCUR(ERRSV)) - sv_catpv(ERRSV, "\t...propagated"); - tmps = SvPV(ERRSV, na); + SV *error = ERRSV; + (void)SvUPGRADE(error, SVt_PV); + if(tmpsv ? SvROK(tmpsv) : SvROK(error)) { + if(tmpsv) + SvSetSV(error,tmpsv); + pat = Nullch; + } + else { + if (SvPOK(error) && SvCUR(error)) + sv_catpv(error, "\t...propagated"); + tmps = SvPV(error, na); + } } if (!tmps || !*tmps) tmps = "Died"; - DIE("%s", tmps); + DIE(pat, tmps); } /* I/O. */ diff --git a/util.c b/util.c index 2db504a..e4f408d 100644 --- a/util.c +++ b/util.c @@ -1279,7 +1279,7 @@ die(pat, va_alist) #else va_start(args); #endif - message = mess(pat, &args); + message = pat ? mess(pat, &args) : Nullch; va_end(args); #ifdef USE_THREADS @@ -1300,9 +1300,14 @@ die(pat, va_alist) SV *msg; ENTER; - msg = newSVpv(message, 0); - SvREADONLY_on(msg); - SAVEFREESV(msg); + if(message) { + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); + } + else { + msg = ERRSV; + } PUSHSTACK(SI_DIEHOOK); PUSHMARK(SP);