diff options
Diffstat (limited to 'gnu')
71 files changed, 1415 insertions, 971 deletions
diff --git a/gnu/usr.bin/perl/Configure b/gnu/usr.bin/perl/Configure index 5a353d6de43..72381fb3ccb 100644 --- a/gnu/usr.bin/perl/Configure +++ b/gnu/usr.bin/perl/Configure @@ -5459,6 +5459,25 @@ default|recommended) eval $checkccflag ;; esac + case "$gccversion" in + 1*) ;; + 2*) ;; + ?*) echo " " + echo "Checking if your compiler accepts -fno-delete-null-pointer-checks" 2>&1 + echo 'int main(void) { return 0; }' > gcctest.c + if $cc -O2 -Werror -fno-delete-null-pointer-checks -o gcctest gcctest.c; then + echo "Yes, it does." 2>&1 + case "$ccflags" in + *delete-null-pointer-checks*) + echo "Leaving current flags $ccflags alone." 2>&1 + ;; + *) dflt="$dflt -fno-delete-null-pointer-checks" ;; + esac + else + echo "Nope, it doesn't, but that's ok." 2>&1 + fi + ;; + esac # For gcc, adding -pipe speeds up compilations for some, but apparently # some assemblers can't read from stdin. (It also slows down compilations # in other cases, but those are apparently rarer these days.) AD 5/2004. @@ -20471,8 +20490,8 @@ $cat >try.c <<EOP #define DOUBLESIZE $doublesize #$d_longdbl HAS_LONG_DOUBLE #ifdef HAS_LONG_DOUBLE -#define LONGDBLSIZE $longdblsize -#define LONGDBLKIND $longdblkind +#define LONG_DOUBLESIZE $longdblsize +#define LONG_DOUBLEKIND $longdblkind #endif #$i_math I_MATH #ifdef I_MATH @@ -20504,16 +20523,15 @@ int main(int argc, char *argv[]) { #ifdef HAS_LONG_DOUBLE long double ldinf = (long double)exp(1e9); long double ldnan = (long double)sqrt(-1.0); -#endif - if (argc == 2) { - switch (argv[1][0]) { - case '1': bytes(&dinf, sizeof(dinf)); break; - case '2': bytes(&dnan, sizeof(dnan)); break; -#ifdef HAS_LONG_DOUBLE # if LONG_DOUBLEKIND == 3 || LONG_DOUBLEKIND == 4 /* the 80-bit long doubles might have garbage in their excess bytes */ memset((char *)&ldinf + 10, '\0', LONG_DOUBLESIZE - 10); + memset((char *)&ldnan + 10, '\0', LONG_DOUBLESIZE - 10); # endif + if (argc == 2) { + switch (argv[1][0]) { + case '1': bytes(&dinf, sizeof(dinf)); break; + case '2': bytes(&dnan, sizeof(dnan)); break; case '3': bytes(&ldinf, sizeof(ldinf)); break; case '4': bytes(&ldnan, sizeof(ldnan)); break; #endif @@ -20741,9 +20759,9 @@ case "$ccflags" in ;; esac -randfunc=Perl_drand48 -drand01="Perl_drand48()" -seedfunc="Perl_drand48_init" +randfunc=drand48 +drand01="drand48()" +seedfunc="srand48" randbits=48 randseedtype=U32 @@ -23594,6 +23612,7 @@ xs_extensions='' find_extensions=' for xxx in *; do case "$xxx" in + CVS) ;; DynaLoader|dynaload) ;; *) this_ext=`echo "$xxx" | $sed -e s/-/\\\//g`; @@ -23831,6 +23850,8 @@ esac nonxs_ext='' for xxx in $nonxs_extensions ; do case "$xxx" in + CVS|RCS|SCCS|.svn) + ;; VMS*) ;; *) nonxs_ext="$nonxs_ext $xxx" diff --git a/gnu/usr.bin/perl/MANIFEST b/gnu/usr.bin/perl/MANIFEST index 567fb5132ba..25e5de85799 100644 --- a/gnu/usr.bin/perl/MANIFEST +++ b/gnu/usr.bin/perl/MANIFEST @@ -14,6 +14,7 @@ cflags.SH A script that emits C compilation flags per file Changes Describe how to peruse changes between releases charclass_invlists.h Compiled-in inversion lists config_h.SH Produces config.h +config.over Site-specific overrides for Configure defaults configpm Produces lib/Config.pm Configure Portability tool configure.com Configure-equivalent for VMS @@ -1803,6 +1804,13 @@ cpan/NEXT/t/dynamically_scoped_regex_vars.t NEXT cpan/NEXT/t/next.t NEXT cpan/NEXT/t/stringify.t NEXT cpan/NEXT/t/unseen.t NEXT +cpan/OpenBSD-MkTemp/lib/OpenBSD/MkTemp.pm OpenBSD::MkTemp +cpan/OpenBSD-MkTemp/MkTemp.xs OpenBSD::MkTemp +cpan/OpenBSD-MkTemp/README OpenBSD::MkTemp Readme +cpan/OpenBSD-MkTemp/t/OpenBSD-MkTemp.t OpenBSD::MkTemp test file +cpan/OpenBSD-Pledge/lib/OpenBSD/Pledge.pm OpenBSD::Pledge +cpan/OpenBSD-Pledge/Pledge.xs OpenBSD::Pledge +cpan/OpenBSD-Pledge/t/OpenBSD-Pledge.t OpenBSD::Pledge test file cpan/Params-Check/lib/Params/Check.pm Params::Check cpan/Params-Check/t/01_Params-Check.t Params::Check tests cpan/parent/lib/parent.pm Establish an ISA relationship with base classes at compile time @@ -2263,6 +2271,17 @@ cpan/Term-ANSIColor/t/module/stringify.t cpan/Term-ANSIColor/t/taint/basic.t cpan/Term-Cap/Cap.pm Perl module supporting termcap usage cpan/Term-Cap/test.pl See if Term::Cap works +cpan/Term-ReadKey/Changes Term::ReadKey +cpan/Term-ReadKey/Configure.pm Term::ReadKey +cpan/Term-ReadKey/example/test.pl Term::ReadKey +cpan/Term-ReadKey/genchars.pl Term::ReadKey +cpan/Term-ReadKey/Makefile.PL Term::ReadKey +cpan/Term-ReadKey/ppport.h Term::ReadKey +cpan/Term-ReadKey/ReadKey.pm Term::ReadKey +cpan/Term-ReadKey/ReadKey.xs Term::ReadKey +cpan/Term-ReadKey/README Term::ReadKey +cpan/Term-ReadKey/t/01_basic.t Term::ReadKey +cpan/Term-ReadKey/t/02_terminal_functions.t Term::ReadKey cpan/Test-Harness/bin/prove The prove harness utility cpan/Test-Harness/lib/App/Prove.pm Gubbins for the prove utility cpan/Test-Harness/lib/App/Prove/State.pm Gubbins for the prove utility @@ -3617,7 +3636,6 @@ ext/B/B/Terse.pm Compiler Terse backend ext/B/B/Xref.pm Compiler Xref backend ext/B/B.xs Compiler backend external subroutines ext/B/hints/darwin.pl Hints for named architecture -ext/B/hints/openbsd.pl Hints for named architecture ext/B/Makefile.PL Compiler backend makefile writer ext/B/O.pm Compiler front-end module (-MO=...) ext/B/t/b.t See if B works @@ -4058,6 +4076,7 @@ fakesdio.h stdio in terms of PerlIO feature.h Feature header form.h Public declarations for formats generate_uudmap.c Generate uudmap.h, the uuencode decoding map +git_version.h Pre-generated git_version.h for OpenBSD globals.c File to declare global symbols (for shared library) globvar.sym Global variables that need hiding when embedded gv.c Glob value code @@ -4202,6 +4221,7 @@ lib/Class/Struct.pm Declare struct-like datatypes as Perl classes lib/Class/Struct.t See if Class::Struct works lib/Config/Extensions.pm Convenient hash lookup for built extensions lib/Config/Extensions.t See if Config::Extensions works +lib/Config_git.pl Pre-generated Config_git.pl for OpenBSD lib/Config.t See if Config works lib/CORE.pod document the CORE namespace lib/DBM_Filter/compress.pm DBM Filter to compress keys/values diff --git a/gnu/usr.bin/perl/Makefile.SH b/gnu/usr.bin/perl/Makefile.SH index 811dfe9e033..212fe6539c0 100644 --- a/gnu/usr.bin/perl/Makefile.SH +++ b/gnu/usr.bin/perl/Makefile.SH @@ -464,7 +464,7 @@ shextract=`SH_to_target $SH` ## In the following dollars and backticks do not need the extra backslash. $spitshell >>$Makefile <<!GROK!THIS! -private = preplibrary \$(CONFIGPM) \$(CONFIGPOD) git_version.h lib/buildcustomize.pl +private = preplibrary \$(CONFIGPM) \$(CONFIGPOD) lib/buildcustomize.pl # Files to be built with variable substitution before miniperl # is available. @@ -607,15 +607,16 @@ $(MANIFEST_SRT): MANIFEST $(PERL_EXE) .PHONY: all utilities +# OpenBSD uses pre-generated lib/Config_git.pl and git_version.h files # Both git_version.h and lib/Config_git.pl are built # by make_patchnum.pl. -git_version.h: lib/Config_git.pl - -lib/Config_git.pl: $(MINIPERL_EXE) make_patchnum.pl - $(MINIPERL) make_patchnum.pl - -# make sure that we recompile perl.c if the git version changes -perl$(OBJ_EXT): git_version.h +#git_version.h: lib/Config_git.pl +# +#lib/Config_git.pl: $(MINIPERL_EXE) make_patchnum.pl +# $(MINIPERL) make_patchnum.pl +# +## make sure that we recompile perl.c if the git version changes +#perl$(OBJ_EXT): git_version.h !NO!SUBS! @@ -781,11 +782,11 @@ CCDLFLAGS = `echo $ccdlflags|sed -e 's@-bE:.*/perl\.exp@-bE:perl.exp@'` LIBPERL_NONSHR = libperl_nonshr$(LIB_EXT) MINIPERL_NONSHR = miniperl_nonshr$(EXE_EXT) -$(LIBPERL_NONSHR): $(perllib_objs) - $(RMS) $(LIBPERL_NONSHR) - $(AR) rc $(LIBPERL_NONSHR) $(perllib_objs) +#$(LIBPERL_NONSHR): $(perllib_objs) +# $(RMS) $(LIBPERL_NONSHR) +# $(AR) rc $(LIBPERL_NONSHR) $(perllib_objs) -$(MINIPERL_NONSHR): $(LIBPERL_NONSHR) miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) perlmini$(OBJ_EXT) +$(MINIPERL_NONSHR): miniperlmain$(OBJ_EXT) opmini$(OBJ_EXT) perlmini$(OBJ_EXT) $(CC) $(LDFLAGS) -o $(MINIPERL_NONSHR) miniperlmain$(OBJ_EXT) \ opmini$(OBJ_EXT) perlmini$(OBJ_EXT) $(LIBPERL_NONSHR) $(LIBS) @@ -872,33 +873,33 @@ $(DTRACE_MAIN_O): perldtrace.d perlmain$(OBJ_EXT) ;; esac $spitshell >>$Makefile <<'!NO!SUBS!' -$(LIBPERL): $& $(perllib_objs) $(DYNALOADER) $(LIBPERLEXPORT) -!NO!SUBS! - case "$useshrplib" in - true) - $spitshell >>$Makefile <<'!NO!SUBS!' - rm -f $@ - $(LD) -o $@ $(SHRPLDFLAGS) $(perllib_objs) $(DYNALOADER) $(libs) -!NO!SUBS! - case "$osname" in - aix) - $spitshell >>$Makefile <<'!NO!SUBS!' - rm -f libperl$(OBJ_EXT) - mv $@ libperl$(OBJ_EXT) - $(AR) qv $(LIBPERL) libperl$(OBJ_EXT) -!NO!SUBS! - ;; - esac - ;; - *) - $spitshell >>$Makefile <<'!NO!SUBS!' - rm -f $(LIBPERL) - $(AR) rc $(LIBPERL) $(perllib_objs) $(DYNALOADER) - @$(ranlib) $(LIBPERL) -!NO!SUBS! - ;; - esac - $spitshell >>$Makefile <<'!NO!SUBS!' +#$(LIBPERL): $& $(perllib_objs) $(DYNALOADER) $(LIBPERLEXPORT) +#!NO!SUBS! +# case "$useshrplib" in +# true) +# $spitshell >>$Makefile <<'!NO!SUBS!' +# rm -f $@ +# $(LD) -o $@ $(SHRPLDFLAGS) $(perllib_objs) $(DYNALOADER) $(libs) +#!NO!SUBS! +# case "$osname" in +# aix) +# $spitshell >>$Makefile <<'!NO!SUBS!' +# rm -f libperl$(OBJ_EXT) +# mv $@ libperl$(OBJ_EXT) +# $(AR) qv $(LIBPERL) libperl$(OBJ_EXT) +#!NO!SUBS! +# ;; +# esac +# ;; +# *) +# $spitshell >>$Makefile <<'!NO!SUBS!' +# rm -f $(LIBPERL) +# $(AR) rc $(LIBPERL) $(perllib_objs) $(DYNALOADER) +# @$(ranlib) $(LIBPERL) +#!NO!SUBS! +# ;; +# esac +# $spitshell >>$Makefile <<'!NO!SUBS!' # How to build executables. @@ -963,10 +964,6 @@ NAMESPACEFLAGS = -force_flat_namespace esac $spitshell >>$Makefile <<'!NO!SUBS!' lib/buildcustomize.pl: $& $(miniperl_objs) write_buildcustomize.pl - -@rm -f miniperl.xok - $(CC) $(CLDFLAGS) $(NAMESPACEFLAGS) -o $(MINIPERL_EXE) \ - $(miniperl_objs) $(libs) - $(LDLIBPTH) ./miniperl$(HOST_EXE_EXT) -w -Ilib -Idist/Exporter/lib -MExporter -e '<?>' || sh -c 'echo >&2 Failed to build miniperl. Please run make minitest; exit 1' $(MINIPERL) -f write_buildcustomize.pl !NO!SUBS! ;; @@ -1066,10 +1063,7 @@ $(CONFIGPOD): config.sh $(MINIPERL_EXE) configpm Porting/Glossary lib/Config_git unidatafiles $(unidatafiles) pod/perluniprops.pod: uni.data uni.data: $(MINIPERL_EXE) $(CONFIGPM) lib/unicore/mktables $(nonxs_ext) - $(MINIPERL) lib/unicore/mktables -C lib/unicore -P pod -maketest -makelist -p -# Commented out so always runs, mktables looks at far more files than we -# can in this makefile to decide if needs to run or not -# touch uni.data + touch uni.data # $(PERL_EXE) and ext because pod_lib.pl needs Digest::MD5 # But also this ensures that all extensions are built before we try to scan @@ -1333,7 +1327,7 @@ _mopup: -rm -f *perl.xok -rm -f cygwin.c libperl*.def libperl*.dll cygperl*.dll *.exe.stackdump -rm -f $(PERL_EXE) $(MINIPERL_EXE) $(LIBPERL) libperl.* microperl - -rm -f config.arch config.over $(DTRACE_H) + -rm -f $(DTRACE_H) _cleaner1: -cd os2; rm -f Makefile @@ -1385,18 +1379,18 @@ _cleaner2: -rmdir lib/Sys/Syslog lib/Sys lib/Sub lib/Search lib/Scalar -rmdir lib/Pod/Text lib/Pod/Simple lib/Pod/Perldoc lib/PerlIO/via -rmdir lib/PerlIO lib/Perl lib/Parse/CPAN lib/Parse lib/Params - -rmdir lib/Net/FTP lib/Module/Load lib/Module/CoreList lib/Module - -rmdir lib/Memoize lib/Math/BigInt lib/Math/BigFloat lib/Math lib/MIME - -rmdir lib/Locale/Maketext lib/Locale/Codes lib/Locale lib/List/Util - -rmdir lib/List lib/JSON/PP lib/JSON lib/IPC lib/IO/Uncompress/Adapter - -rmdir lib/IO/Uncompress lib/IO/Socket lib/IO/Compress/Zlib - -rmdir lib/IO/Compress/Zip lib/IO/Compress/Gzip lib/IO/Compress/Base - -rmdir lib/IO/Compress/Adapter lib/IO/Compress lib/IO - -rmdir lib/I18N/LangTags lib/I18N lib/Hash/Util lib/Hash lib/HTTP - -rmdir lib/Filter/Util lib/Filter lib/File/Spec lib/ExtUtils/Typemaps - -rmdir lib/ExtUtils/ParseXS lib/ExtUtils/MakeMaker/version - -rmdir lib/ExtUtils/MakeMaker lib/ExtUtils/Liblist - -rmdir lib/ExtUtils/Constant lib/ExtUtils/Command + -rmdir lib/OpenBSD lib/Net/FTP lib/Module/Load lib/Module/CoreList + -rmdir lib/Module lib/Memoize lib/Math/BigInt lib/Math/BigFloat + -rmdir lib/Math lib/MIME lib/Locale/Maketext lib/Locale/Codes + -rmdir lib/Locale lib/List/Util lib/List lib/JSON/PP lib/JSON lib/IPC + -rmdir lib/IO/Uncompress/Adapter lib/IO/Uncompress lib/IO/Socket + -rmdir lib/IO/Compress/Zlib lib/IO/Compress/Zip lib/IO/Compress/Gzip + -rmdir lib/IO/Compress/Base lib/IO/Compress/Adapter lib/IO/Compress + -rmdir lib/IO lib/I18N/LangTags lib/I18N lib/Hash/Util lib/Hash + -rmdir lib/HTTP lib/Filter/Util lib/Filter lib/File/Spec + -rmdir lib/ExtUtils/Typemaps lib/ExtUtils/ParseXS + -rmdir lib/ExtUtils/MakeMaker/version lib/ExtUtils/MakeMaker + -rmdir lib/ExtUtils/Liblist lib/ExtUtils/Constant lib/ExtUtils/Command -rmdir lib/ExtUtils/CBuilder/Platform/Windows -rmdir lib/ExtUtils/CBuilder/Platform lib/ExtUtils/CBuilder -rmdir lib/Exporter lib/Encode/Unicode lib/Encode/MIME/Header diff --git a/gnu/usr.bin/perl/Porting/Maintainers.pl b/gnu/usr.bin/perl/Porting/Maintainers.pl index b924e1017e5..7544867c6cf 100644 --- a/gnu/usr.bin/perl/Porting/Maintainers.pl +++ b/gnu/usr.bin/perl/Porting/Maintainers.pl @@ -1623,6 +1623,9 @@ use File::Glob qw(:case); lib/vmsish.{pm,t} ], }, + 'openbsd' => { + 'FILES' => q[lib/Config_git.pl], + }, ); # legacy CPAN flag diff --git a/gnu/usr.bin/perl/Porting/pumpkin.pod b/gnu/usr.bin/perl/Porting/pumpkin.pod index 3618eec7799..74110428f7d 100644 --- a/gnu/usr.bin/perl/Porting/pumpkin.pod +++ b/gnu/usr.bin/perl/Porting/pumpkin.pod @@ -540,9 +540,9 @@ Here's how I generate a new patch. I'll use the hypothetical 5.004_07 to 5.004_08 patch as an example. # unpack perl5.004_07/ - gzip -d -c perl5.004_07.tar.gz | tar -xof - + gzip -d -c perl5.004_07.tar.gz | tar -xf - # unpack perl5.004_08/ - gzip -d -c perl5.004_08.tar.gz | tar -xof - + gzip -d -c perl5.004_08.tar.gz | tar -xf - makepatch perl5.004_07 perl5.004_08 > perl5.004_08.pat Makepatch will automatically generate appropriate B<rm> commands to remove diff --git a/gnu/usr.bin/perl/configpm b/gnu/usr.bin/perl/configpm index 21bd3ef4f1b..2e44893d45f 100644 --- a/gnu/usr.bin/perl/configpm +++ b/gnu/usr.bin/perl/configpm @@ -1108,6 +1108,18 @@ my $orig_heavy_txt = ""; } if ($orig_config_txt ne $config_txt or $orig_heavy_txt ne $heavy_txt) { + # During the build don't look in /usr/local for libs or includes + # but after, we want to let modules look there. + my $install_heavy_txt = $heavy_txt; + $install_heavy_txt =~ s,^(ccflags|cppflags)[^=]*='[^']+,$& -I/usr/local/include,gm; + $install_heavy_txt =~ s,^(ldflags|lddlflags)[^=]*='[^']+,$& -L/usr/local/lib,gm; + + open INSTALL_CONFIG_HEAVY, ">", "$Config_heavy.install" + or die "Can't open install $Config_heavy: $!\n"; + print INSTALL_CONFIG_HEAVY $install_heavy_txt; + close INSTALL_CONFIG_HEAVY; + print "updated install $Config_heavy\n"; + open CONFIG, ">", $Config_PM or die "Can't open $Config_PM: $!\n"; open CONFIG_HEAVY, ">", $Config_heavy or die "Can't open $Config_heavy: $!\n"; print CONFIG $config_txt; diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/private/MakeUtil.pm b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/private/MakeUtil.pm index 47aebd60743..9d7e5ed262d 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/private/MakeUtil.pm +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/private/MakeUtil.pm @@ -35,7 +35,8 @@ sub MY::libscan my $path = shift; return undef - if $path =~ /(~|\.bak|_bak)$/ || + if $path =~ /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/ || + $path =~ /(~|\.bak|_bak)$/ || $path =~ /\..*\.sw(o|p)$/ || $path =~ /\B\.svn\b/; diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/private/MakeUtil.pm b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/private/MakeUtil.pm index 47aebd60743..9d7e5ed262d 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/private/MakeUtil.pm +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/private/MakeUtil.pm @@ -35,7 +35,8 @@ sub MY::libscan my $path = shift; return undef - if $path =~ /(~|\.bak|_bak)$/ || + if $path =~ /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/ || + $path =~ /(~|\.bak|_bak)$/ || $path =~ /\..*\.sw(o|p)$/ || $path =~ /\B\.svn\b/; diff --git a/gnu/usr.bin/perl/cpan/Digest-MD5/MD5.xs b/gnu/usr.bin/perl/cpan/Digest-MD5/MD5.xs index acefc30711e..d8b156370f6 100644 --- a/gnu/usr.bin/perl/cpan/Digest-MD5/MD5.xs +++ b/gnu/usr.bin/perl/cpan/Digest-MD5/MD5.xs @@ -39,6 +39,8 @@ extern "C" { #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +#include <sys/types.h> +#include <md5.h> #ifdef __cplusplus } #endif @@ -88,61 +90,6 @@ static MAGIC *THX_sv_magicext(pTHX_ SV *sv, SV *obj, int type, # define SvPVbyte(sv, lp) (sv_utf8_downgrade((sv), 0), SvPV((sv), (lp))) #endif -/* Perl does not guarantee that U32 is exactly 32 bits. Some system - * has no integral type with exactly 32 bits. For instance, A Cray has - * short, int and long all at 64 bits so we need to apply this macro - * to reduce U32 values to 32 bits at appropriate places. If U32 - * really does have 32 bits then this is a no-op. - */ -#if BYTEORDER > 0x4321 || defined(TRUNCATE_U32) - #define TO32(x) ((x) & 0xFFFFffff) - #define TRUNC32(x) ((x) &= 0xFFFFffff) -#else - #define TO32(x) (x) - #define TRUNC32(x) /*nothing*/ -#endif - -/* The MD5 algorithm is defined in terms of little endian 32-bit - * values. The following macros (and functions) allow us to convert - * between native integers and such values. - */ -#undef BYTESWAP -#ifndef U32_ALIGNMENT_REQUIRED - #if BYTEORDER == 0x1234 /* 32-bit little endian */ - #define BYTESWAP(x) (x) /* no-op */ - - #elif BYTEORDER == 0x4321 /* 32-bit big endian */ - #define BYTESWAP(x) ((((x)&0xFF)<<24) \ - |(((x)>>24)&0xFF) \ - |(((x)&0x0000FF00)<<8) \ - |(((x)&0x00FF0000)>>8) ) - #endif -#endif - -#ifndef BYTESWAP -static void u2s(U32 u, U8* s) -{ - *s++ = (U8)(u & 0xFF); - *s++ = (U8)((u >> 8) & 0xFF); - *s++ = (U8)((u >> 16) & 0xFF); - *s = (U8)((u >> 24) & 0xFF); -} - -#define s2u(s,u) ((u) = (U32)(*s) | \ - ((U32)(*(s+1)) << 8) | \ - ((U32)(*(s+2)) << 16) | \ - ((U32)(*(s+3)) << 24)) -#endif - -/* This structure keeps the current state of algorithm. - */ -typedef struct { - U32 A, B, C, D; /* current digest */ - U32 bytes_low; /* counts bytes in message */ - U32 bytes_high; /* turn it into a 64-bit counter */ - U8 buffer[128]; /* collect complete 64 byte blocks */ -} MD5_CTX; - #if defined(USE_ITHREADS) && defined(MGf_DUP) STATIC int dup_md5_ctx(pTHX_ MAGIC *mg, CLONE_PARAMS *params) { @@ -179,325 +126,6 @@ const STATIC struct { }; #endif - -/* Padding is added at the end of the message in order to fill a - * complete 64 byte block (- 8 bytes for the message length). The - * padding is also the reason the buffer in MD5_CTX have to be - * 128 bytes. - */ -static const unsigned char PADDING[64] = { - 0x80, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 -}; - -/* Constants for MD5Transform routine. - */ -#define S11 7 -#define S12 12 -#define S13 17 -#define S14 22 -#define S21 5 -#define S22 9 -#define S23 14 -#define S24 20 -#define S31 4 -#define S32 11 -#define S33 16 -#define S34 23 -#define S41 6 -#define S42 10 -#define S43 15 -#define S44 21 - -/* F, G, H and I are basic MD5 functions. - */ -#define F(x, y, z) ((((x) & ((y) ^ (z))) ^ (z))) -#define G(x, y, z) F(z, x, y) -#define H(x, y, z) ((x) ^ (y) ^ (z)) -#define I(x, y, z) ((y) ^ ((x) | (~z))) - -/* ROTATE_LEFT rotates x left n bits. - */ -#define ROTATE_LEFT(x, n) (((x) << (n) | ((x) >> (32-(n))))) - -/* FF, GG, HH, and II transformations for rounds 1, 2, 3, and 4. - * Rotation is separate from addition to prevent recomputation. - */ -#define FF(a, b, c, d, s, ac) \ - (a) += F ((b), (c), (d)) + (NEXTx) + (U32)(ac); \ - TRUNC32((a)); \ - (a) = ROTATE_LEFT ((a), (s)); \ - (a) += (b); \ - TRUNC32((a)); - -#define GG(a, b, c, d, x, s, ac) \ - (a) += G ((b), (c), (d)) + X[x] + (U32)(ac); \ - TRUNC32((a)); \ - (a) = ROTATE_LEFT ((a), (s)); \ - (a) += (b); \ - TRUNC32((a)); - -#define HH(a, b, c, d, x, s, ac) \ - (a) += H ((b), (c), (d)) + X[x] + (U32)(ac); \ - TRUNC32((a)); \ - (a) = ROTATE_LEFT ((a), (s)); \ - (a) += (b); \ - TRUNC32((a)); - -#define II(a, b, c, d, x, s, ac) \ - (a) += I ((b), (c), (d)) + X[x] + (U32)(ac); \ - TRUNC32((a)); \ - (a) = ROTATE_LEFT ((a), (s)); \ - (a) += (b); \ - TRUNC32((a)); - - -static void -MD5Init(MD5_CTX *ctx) -{ - /* Start state */ - ctx->A = 0x67452301; - ctx->B = 0xefcdab89; - ctx->C = 0x98badcfe; - ctx->D = 0x10325476; - - /* message length */ - ctx->bytes_low = ctx->bytes_high = 0; -} - - -static void -MD5Transform(MD5_CTX* ctx, const U8* buf, STRLEN blocks) -{ -#ifdef MD5_DEBUG - static int tcount = 0; -#endif - - U32 A = ctx->A; - U32 B = ctx->B; - U32 C = ctx->C; - U32 D = ctx->D; - -#ifndef U32_ALIGNMENT_REQUIRED - const U32 *x = (U32*)buf; /* really just type casting */ -#endif - - do { - U32 a = A; - U32 b = B; - U32 c = C; - U32 d = D; - -#if BYTEORDER == 0x1234 && !defined(U32_ALIGNMENT_REQUIRED) - const U32 *X = x; - #define NEXTx (*x++) -#else - U32 X[16]; /* converted values, used in round 2-4 */ - U32 *uptr = X; - U32 tmp; - #ifdef BYTESWAP - #define NEXTx (tmp=*x++, *uptr++ = BYTESWAP(tmp)) - #else - #define NEXTx (s2u(buf,tmp), buf += 4, *uptr++ = tmp) - #endif -#endif - -#ifdef MD5_DEBUG - if (buf == ctx->buffer) - fprintf(stderr,"%5d: Transform ctx->buffer", ++tcount); - else - fprintf(stderr,"%5d: Transform %p (%d)", ++tcount, buf, blocks); - - { - int i; - fprintf(stderr,"["); - for (i = 0; i < 16; i++) { - fprintf(stderr,"%x,", x[i]); - } - fprintf(stderr,"]\n"); - } -#endif - - /* Round 1 */ - FF (a, b, c, d, S11, 0xd76aa478); /* 1 */ - FF (d, a, b, c, S12, 0xe8c7b756); /* 2 */ - FF (c, d, a, b, S13, 0x242070db); /* 3 */ - FF (b, c, d, a, S14, 0xc1bdceee); /* 4 */ - FF (a, b, c, d, S11, 0xf57c0faf); /* 5 */ - FF (d, a, b, c, S12, 0x4787c62a); /* 6 */ - FF (c, d, a, b, S13, 0xa8304613); /* 7 */ - FF (b, c, d, a, S14, 0xfd469501); /* 8 */ - FF (a, b, c, d, S11, 0x698098d8); /* 9 */ - FF (d, a, b, c, S12, 0x8b44f7af); /* 10 */ - FF (c, d, a, b, S13, 0xffff5bb1); /* 11 */ - FF (b, c, d, a, S14, 0x895cd7be); /* 12 */ - FF (a, b, c, d, S11, 0x6b901122); /* 13 */ - FF (d, a, b, c, S12, 0xfd987193); /* 14 */ - FF (c, d, a, b, S13, 0xa679438e); /* 15 */ - FF (b, c, d, a, S14, 0x49b40821); /* 16 */ - - /* Round 2 */ - GG (a, b, c, d, 1, S21, 0xf61e2562); /* 17 */ - GG (d, a, b, c, 6, S22, 0xc040b340); /* 18 */ - GG (c, d, a, b, 11, S23, 0x265e5a51); /* 19 */ - GG (b, c, d, a, 0, S24, 0xe9b6c7aa); /* 20 */ - GG (a, b, c, d, 5, S21, 0xd62f105d); /* 21 */ - GG (d, a, b, c, 10, S22, 0x2441453); /* 22 */ - GG (c, d, a, b, 15, S23, 0xd8a1e681); /* 23 */ - GG (b, c, d, a, 4, S24, 0xe7d3fbc8); /* 24 */ - GG (a, b, c, d, 9, S21, 0x21e1cde6); /* 25 */ - GG (d, a, b, c, 14, S22, 0xc33707d6); /* 26 */ - GG (c, d, a, b, 3, S23, 0xf4d50d87); /* 27 */ - GG (b, c, d, a, 8, S24, 0x455a14ed); /* 28 */ - GG (a, b, c, d, 13, S21, 0xa9e3e905); /* 29 */ - GG (d, a, b, c, 2, S22, 0xfcefa3f8); /* 30 */ - GG (c, d, a, b, 7, S23, 0x676f02d9); /* 31 */ - GG (b, c, d, a, 12, S24, 0x8d2a4c8a); /* 32 */ - - /* Round 3 */ - HH (a, b, c, d, 5, S31, 0xfffa3942); /* 33 */ - HH (d, a, b, c, 8, S32, 0x8771f681); /* 34 */ - HH (c, d, a, b, 11, S33, 0x6d9d6122); /* 35 */ - HH (b, c, d, a, 14, S34, 0xfde5380c); /* 36 */ - HH (a, b, c, d, 1, S31, 0xa4beea44); /* 37 */ - HH (d, a, b, c, 4, S32, 0x4bdecfa9); /* 38 */ - HH (c, d, a, b, 7, S33, 0xf6bb4b60); /* 39 */ - HH (b, c, d, a, 10, S34, 0xbebfbc70); /* 40 */ - HH (a, b, c, d, 13, S31, 0x289b7ec6); /* 41 */ - HH (d, a, b, c, 0, S32, 0xeaa127fa); /* 42 */ - HH (c, d, a, b, 3, S33, 0xd4ef3085); /* 43 */ - HH (b, c, d, a, 6, S34, 0x4881d05); /* 44 */ - HH (a, b, c, d, 9, S31, 0xd9d4d039); /* 45 */ - HH (d, a, b, c, 12, S32, 0xe6db99e5); /* 46 */ - HH (c, d, a, b, 15, S33, 0x1fa27cf8); /* 47 */ - HH (b, c, d, a, 2, S34, 0xc4ac5665); /* 48 */ - - /* Round 4 */ - II (a, b, c, d, 0, S41, 0xf4292244); /* 49 */ - II (d, a, b, c, 7, S42, 0x432aff97); /* 50 */ - II (c, d, a, b, 14, S43, 0xab9423a7); /* 51 */ - II (b, c, d, a, 5, S44, 0xfc93a039); /* 52 */ - II (a, b, c, d, 12, S41, 0x655b59c3); /* 53 */ - II (d, a, b, c, 3, S42, 0x8f0ccc92); /* 54 */ - II (c, d, a, b, 10, S43, 0xffeff47d); /* 55 */ - II (b, c, d, a, 1, S44, 0x85845dd1); /* 56 */ - II (a, b, c, d, 8, S41, 0x6fa87e4f); /* 57 */ - II (d, a, b, c, 15, S42, 0xfe2ce6e0); /* 58 */ - II (c, d, a, b, 6, S43, 0xa3014314); /* 59 */ - II (b, c, d, a, 13, S44, 0x4e0811a1); /* 60 */ - II (a, b, c, d, 4, S41, 0xf7537e82); /* 61 */ - II (d, a, b, c, 11, S42, 0xbd3af235); /* 62 */ - II (c, d, a, b, 2, S43, 0x2ad7d2bb); /* 63 */ - II (b, c, d, a, 9, S44, 0xeb86d391); /* 64 */ - - A += a; TRUNC32(A); - B += b; TRUNC32(B); - C += c; TRUNC32(C); - D += d; TRUNC32(D); - - } while (--blocks); - ctx->A = A; - ctx->B = B; - ctx->C = C; - ctx->D = D; -} - - -#ifdef MD5_DEBUG -static char* -ctx_dump(MD5_CTX* ctx) -{ - static char buf[1024]; - sprintf(buf, "{A=%x,B=%x,C=%x,D=%x,%d,%d(%d)}", - ctx->A, ctx->B, ctx->C, ctx->D, - ctx->bytes_low, ctx->bytes_high, (ctx->bytes_low&0x3F)); - return buf; -} -#endif - - -static void -MD5Update(MD5_CTX* ctx, const U8* buf, STRLEN len) -{ - STRLEN blocks; - STRLEN fill = ctx->bytes_low & 0x3F; - -#ifdef MD5_DEBUG - static int ucount = 0; - fprintf(stderr,"%5i: Update(%s, %p, %d)\n", ++ucount, ctx_dump(ctx), - buf, len); -#endif - - ctx->bytes_low += len; - if (ctx->bytes_low < len) /* wrap around */ - ctx->bytes_high++; - - if (fill) { - STRLEN missing = 64 - fill; - if (len < missing) { - Copy(buf, ctx->buffer + fill, len, U8); - return; - } - Copy(buf, ctx->buffer + fill, missing, U8); - MD5Transform(ctx, ctx->buffer, 1); - buf += missing; - len -= missing; - } - - blocks = len >> 6; - if (blocks) - MD5Transform(ctx, buf, blocks); - if ( (len &= 0x3F)) { - Copy(buf + (blocks << 6), ctx->buffer, len, U8); - } -} - - -static void -MD5Final(U8* digest, MD5_CTX *ctx) -{ - STRLEN fill = ctx->bytes_low & 0x3F; - STRLEN padlen = (fill < 56 ? 56 : 120) - fill; - U32 bits_low, bits_high; -#ifdef MD5_DEBUG - fprintf(stderr," Final: %s\n", ctx_dump(ctx)); -#endif - Copy(PADDING, ctx->buffer + fill, padlen, U8); - fill += padlen; - - bits_low = ctx->bytes_low << 3; - bits_high = (ctx->bytes_high << 3) | (ctx->bytes_low >> 29); -#ifdef BYTESWAP - *(U32*)(ctx->buffer + fill) = BYTESWAP(bits_low); fill += 4; - *(U32*)(ctx->buffer + fill) = BYTESWAP(bits_high); fill += 4; -#else - u2s(bits_low, ctx->buffer + fill); fill += 4; - u2s(bits_high, ctx->buffer + fill); fill += 4; -#endif - - MD5Transform(ctx, ctx->buffer, fill >> 6); -#ifdef MD5_DEBUG - fprintf(stderr," Result: %s\n", ctx_dump(ctx)); -#endif - -#ifdef BYTESWAP - *(U32*)digest = BYTESWAP(ctx->A); digest += 4; - *(U32*)digest = BYTESWAP(ctx->B); digest += 4; - *(U32*)digest = BYTESWAP(ctx->C); digest += 4; - *(U32*)digest = BYTESWAP(ctx->D); -#else - u2s(ctx->A, digest); - u2s(ctx->B, digest+4); - u2s(ctx->C, digest+8); - u2s(ctx->D, digest+12); -#endif -} - -#ifndef INT2PTR -#define INT2PTR(any,d) (any)(d) -#endif - static MD5_CTX* get_md5_ctx(pTHX_ SV* sv) { MAGIC *mg; @@ -678,7 +306,7 @@ addfile(self, fh) InputStream fh PREINIT: MD5_CTX* context = get_md5_ctx(aTHX_ self); - STRLEN fill = context->bytes_low & 0x3F; + STRLEN fill = (context->count >> 3) & (MD5_BLOCK_LENGTH - 1); #ifdef USE_HEAP_INSTEAD_OF_STACK unsigned char* buffer; #else @@ -743,14 +371,12 @@ context(ctx, ...) PPCODE: if (items > 2) { STRLEN len; - unsigned long blocks = SvUV(ST(1)); + ctx->count = SvUV(ST(1)) << 3; unsigned char *buf = (unsigned char *)(SvPV(ST(2), len)); - ctx->A = buf[ 0] | (buf[ 1]<<8) | (buf[ 2]<<16) | (buf[ 3]<<24); - ctx->B = buf[ 4] | (buf[ 5]<<8) | (buf[ 6]<<16) | (buf[ 7]<<24); - ctx->C = buf[ 8] | (buf[ 9]<<8) | (buf[10]<<16) | (buf[11]<<24); - ctx->D = buf[12] | (buf[13]<<8) | (buf[14]<<16) | (buf[15]<<24); - ctx->bytes_low = blocks << 6; - ctx->bytes_high = blocks >> 26; + ctx->state[0] = buf[ 0] | (buf[ 1]<<8) | (buf[ 2]<<16) | (buf[ 3]<<24); + ctx->state[1] = buf[ 4] | (buf[ 5]<<8) | (buf[ 6]<<16) | (buf[ 7]<<24); + ctx->state[2] = buf[ 8] | (buf[ 9]<<8) | (buf[10]<<16) | (buf[11]<<24); + ctx->state[3] = buf[12] | (buf[13]<<8) | (buf[14]<<16) | (buf[15]<<24); if (items == 4) { buf = (unsigned char *)(SvPV(ST(3), len)); MD5Update(ctx, buf, len); @@ -760,17 +386,20 @@ context(ctx, ...) XSRETURN(0); } - w=ctx->A; out[ 0]=w; out[ 1]=(w>>8); out[ 2]=(w>>16); out[ 3]=(w>>24); - w=ctx->B; out[ 4]=w; out[ 5]=(w>>8); out[ 6]=(w>>16); out[ 7]=(w>>24); - w=ctx->C; out[ 8]=w; out[ 9]=(w>>8); out[10]=(w>>16); out[11]=(w>>24); - w=ctx->D; out[12]=w; out[13]=(w>>8); out[14]=(w>>16); out[15]=(w>>24); + w=ctx->state[0]; out[ 0]=w; out[ 1]=(w>>8); out[ 2]=(w>>16); out[ 3]=(w>>24); + w=ctx->state[1]; out[ 4]=w; out[ 5]=(w>>8); out[ 6]=(w>>16); out[ 7]=(w>>24); + w=ctx->state[2]; out[ 8]=w; out[ 9]=(w>>8); out[10]=(w>>16); out[11]=(w>>24); + w=ctx->state[3]; out[12]=w; out[13]=(w>>8); out[14]=(w>>16); out[15]=(w>>24); EXTEND(SP, 3); - ST(0) = sv_2mortal(newSVuv(ctx->bytes_high << 26 | - ctx->bytes_low >> 6)); + ST(0) = sv_2mortal(newSViv((ctx->count >> 3) + - ((ctx->count >> 3) % MD5_BLOCK_LENGTH))); ST(1) = sv_2mortal(newSVpv(out, 16)); - ST(2) = sv_2mortal(newSVpv((char *)ctx->buffer, - ctx->bytes_low & 0x3F)); + ST(2) = sv_2mortal(newSVpv("",0)); + if (((ctx->count >> 3) & (MD5_BLOCK_LENGTH - 1)) != 0) + ST(2) = sv_2mortal(newSVpv((char *)ctx->buffer, + (ctx->count >> 3) & (MD5_BLOCK_LENGTH - 1))); + XSRETURN(3); void diff --git a/gnu/usr.bin/perl/cpan/Digest-MD5/t/files.t b/gnu/usr.bin/perl/cpan/Digest-MD5/t/files.t index d6b4fcb2cd7..14a39925707 100755 --- a/gnu/usr.bin/perl/cpan/Digest-MD5/t/files.t +++ b/gnu/usr.bin/perl/cpan/Digest-MD5/t/files.t @@ -21,7 +21,7 @@ EOT # This is the output of: 'md5sum README MD5.xs rfc1321.txt' $EXPECT = <<EOT; 2f93400875dbb56f36691d5f69f3eba5 README -0a0cf2512d18d24c6881d7d755e2b609 MD5.xs +5457ac1c3f0f33df96437555dc7eb172 MD5.xs 754b9db19f79dbc4992f7166eb0f37ce rfc1321.txt EOT } diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm b/gnu/usr.bin/perl/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm index 1e8ac4cd12b..1b98c4321e2 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm @@ -100,6 +100,7 @@ my $Is_MacPerl = $^O eq 'MacOS'; my $Is_Win32 = $^O eq 'MSWin32'; my $Is_cygwin = $^O eq 'cygwin'; my $CanMoveAtBoot = ($Is_Win32 || $Is_cygwin); +my $Perm_Dir = $ENV{PERL_CORE} ? 0770 : 0755; # *note* CanMoveAtBoot is only incidentally the same condition as below # this needs not hold true in the future. @@ -783,7 +784,7 @@ sub install { #XXX OS-SPECIFIC _chdir($cwd); } foreach my $targetdir (sort keys %check_dirs) { - _mkpath( $targetdir, 0, 0755, $verbose, $dry_run ); + _mkpath( $targetdir, 0, $Perm_Dir, $verbose, $dry_run ); } foreach my $found (@found_files) { my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime, @@ -797,7 +798,7 @@ sub install { #XXX OS-SPECIFIC $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' ) unless $dry_run; } elsif ( ! -d $targetdir ) { - _mkpath( $targetdir, 0, 0755, $verbose, $dry_run ); + _mkpath( $targetdir, 0, $Perm_Dir, $verbose, $dry_run ); } print "Installing $targetfile\n"; @@ -837,7 +838,7 @@ sub install { #XXX OS-SPECIFIC if ($pack{'write'}) { $dir = install_rooted_dir(dirname($pack{'write'})); - _mkpath( $dir, 0, 0755, $verbose, $dry_run ); + _mkpath( $dir, 0, $Perm_Dir, $verbose, $dry_run ); print "Writing $pack{'write'}\n" if $verbose; $packlist->write(install_rooted_file($pack{'write'})) unless $dry_run; } @@ -1180,7 +1181,7 @@ environment variable will silence this output. sub pm_to_blib { my($fromto,$autodir,$pm_filter) = @_; - _mkpath($autodir,0,0755); + _mkpath($autodir,0,$Perm_Dir); while(my($from, $to) = each %$fromto) { if( -f $to && -s $from == -s $to && -M $to < -M $from ) { print "Skip $to (unchanged)\n" unless $INSTALL_QUIET; @@ -1203,7 +1204,7 @@ sub pm_to_blib { # we wont try hard here. its too likely to mess things up. forceunlink($to); } else { - _mkpath(dirname($to),0,0755); + _mkpath(dirname($to),0,$Perm_Dir); } if ($need_filtering) { run_filter($pm_filter, $from, $to); diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm index 009b18ee085..785daaaed32 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm @@ -933,7 +933,7 @@ OTHERLDFLAGS = '.$ld_opt.$otherldflags.' INST_DYNAMIC_DEP = '.$inst_dynamic_dep.' INST_DYNAMIC_FIX = '.$ld_fix.' -$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) +$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) '); if ($armaybe ne ':'){ $ldfrom = 'tmp$(LIB_EXT)'; @@ -985,7 +985,7 @@ MAKE push @m, <<'MAKE'; $(CHMOD) $(PERM_RWX) $@ - $(NOECHO) $(RM_RF) $(BOOTSTRAP) + $(NOECHO) $(RM_RF) $(INST_BOOT) - $(CP_NONEMPTY) $(BOOTSTRAP) $(INST_BOOT) $(PERM_RW) MAKE @@ -2049,7 +2049,8 @@ Called by init_main. Initializes PERL_* sub init_PERM { my($self) = shift; - $self->{PERM_DIR} = 755 unless defined $self->{PERM_DIR}; + my $perm_dir = $self->{PERL_CORE} ? 770 : 755; + $self->{PERM_DIR} = $perm_dir unless defined $self->{PERM_DIR}; $self->{PERM_RW} = 644 unless defined $self->{PERM_RW}; $self->{PERM_RWX} = 755 unless defined $self->{PERM_RWX}; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/eu_command.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/eu_command.t index 269aa5c9a4c..32a6f59dcab 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/eu_command.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/eu_command.t @@ -151,20 +151,21 @@ BEGIN { is( ((stat('testdir'))[2] & 07777) & 0700, 0100, 'change a dir to execute-only' ); - # change a dir to read-only - @ARGV = ( '0400', 'testdir' ); + # change a dir to write-only + @ARGV = ( '0200', 'testdir' ); ExtUtils::Command::chmod(); is( ((stat('testdir'))[2] & 07777) & 0700, - 0400, 'change a dir to read-only' ); + 0200, 'change a dir to write-only' ); - # change a dir to write-only - @ARGV = ( '0200', 'testdir' ); + # change a dir to read-only + @ARGV = ( '0400', 'testdir' ); ExtUtils::Command::chmod(); is( ((stat('testdir'))[2] & 07777) & 0700, - 0200, 'change a dir to write-only' ); + 0400, 'change a dir to read-only' ); + # remove the dir we've been playing with @ARGV = ('testdir'); rm_rf; ok( ! -e 'testdir', 'rm_rf can delete a read-only dir' ); diff --git a/gnu/usr.bin/perl/cpan/File-Path/lib/File/Path.pm b/gnu/usr.bin/perl/cpan/File-Path/lib/File/Path.pm index 034da1e578d..138bdc24ffb 100644 --- a/gnu/usr.bin/perl/cpan/File-Path/lib/File/Path.pm +++ b/gnu/usr.bin/perl/cpan/File-Path/lib/File/Path.pm @@ -18,7 +18,7 @@ BEGIN { use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); -$VERSION = '2.12_01'; +$VERSION = '2.13'; $VERSION = eval $VERSION; @ISA = qw(Exporter); @EXPORT = qw(mkpath rmtree); @@ -85,15 +85,15 @@ sub make_path { sub mkpath { my $old_style = !( @_ and __is_arg( $_[-1] ) ); - my $arg; + my $data; my $paths; if ($old_style) { my ( $verbose, $mode ); ( $paths, $verbose, $mode ) = @_; $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' ); - $arg->{verbose} = $verbose; - $arg->{mode} = defined $mode ? $mode : oct '777'; + $data->{verbose} = $verbose; + $data->{mode} = defined $mode ? $mode : oct '777'; } else { my %args_permitted = map { $_ => 1 } ( qw| @@ -107,55 +107,74 @@ sub mkpath { user verbose | ); + my %not_on_win32_args = map { $_ => 1 } ( qw| + group + owner + uid + user + | ); my @bad_args = (); - $arg = pop @_; + my @win32_implausible_args = (); + my $arg = pop @_; for my $k (sort keys %{$arg}) { - push @bad_args, $k unless $args_permitted{$k}; - } - _carp("Unrecognized option(s) passed to make_path(): @bad_args") - if @bad_args; - $arg->{mode} = delete $arg->{mask} if exists $arg->{mask}; - $arg->{mode} = oct '777' unless exists $arg->{mode}; - ${ $arg->{error} } = [] if exists $arg->{error}; - $arg->{owner} = delete $arg->{user} if exists $arg->{user}; - $arg->{owner} = delete $arg->{uid} if exists $arg->{uid}; - if ( exists $arg->{owner} and $arg->{owner} =~ /\D/ ) { - my $uid = ( getpwnam $arg->{owner} )[2]; - if ( defined $uid ) { - $arg->{owner} = $uid; + if (! $args_permitted{$k}) { + push @bad_args, $k; + } + elsif ($not_on_win32_args{$k} and _IS_MSWIN32) { + push @win32_implausible_args, $k; } else { - _error( $arg, -"unable to map $arg->{owner} to a uid, ownership not changed" - ); - delete $arg->{owner}; + $data->{$k} = $arg->{$k}; } } - if ( exists $arg->{group} and $arg->{group} =~ /\D/ ) { - my $gid = ( getgrnam $arg->{group} )[2]; - if ( defined $gid ) { - $arg->{group} = $gid; + _carp("Unrecognized option(s) passed to mkpath() or make_path(): @bad_args") + if @bad_args; + _carp("Option(s) implausible on Win32 passed to mkpath() or make_path(): @win32_implausible_args") + if @win32_implausible_args; + $data->{mode} = delete $data->{mask} if exists $data->{mask}; + $data->{mode} = oct '777' unless exists $data->{mode}; + ${ $data->{error} } = [] if exists $data->{error}; + unless (@win32_implausible_args) { + $data->{owner} = delete $data->{user} if exists $data->{user}; + $data->{owner} = delete $data->{uid} if exists $data->{uid}; + if ( exists $data->{owner} and $data->{owner} =~ /\D/ ) { + my $uid = ( getpwnam $data->{owner} )[2]; + if ( defined $uid ) { + $data->{owner} = $uid; + } + else { + _error( $data, + "unable to map $data->{owner} to a uid, ownership not changed" + ); + delete $data->{owner}; + } } - else { - _error( $arg, -"unable to map $arg->{group} to a gid, group ownership not changed" - ); - delete $arg->{group}; + if ( exists $data->{group} and $data->{group} =~ /\D/ ) { + my $gid = ( getgrnam $data->{group} )[2]; + if ( defined $gid ) { + $data->{group} = $gid; + } + else { + _error( $data, + "unable to map $data->{group} to a gid, group ownership not changed" + ); + delete $data->{group}; + } + } + if ( exists $data->{owner} and not exists $data->{group} ) { + $data->{group} = -1; # chown will leave group unchanged + } + if ( exists $data->{group} and not exists $data->{owner} ) { + $data->{owner} = -1; # chown will leave owner unchanged } - } - if ( exists $arg->{owner} and not exists $arg->{group} ) { - $arg->{group} = -1; # chown will leave group unchanged - } - if ( exists $arg->{group} and not exists $arg->{owner} ) { - $arg->{owner} = -1; # chown will leave owner unchanged } $paths = [@_]; } - return _mkpath( $arg, $paths ); + return _mkpath( $data, $paths ); } sub _mkpath { - my $arg = shift; + my $data = shift; my $paths = shift; my ( @created ); @@ -170,38 +189,51 @@ sub _mkpath { } next if -d $path; my $parent = File::Basename::dirname($path); + # Coverage note: It's not clear how we would test the condition: + # '-d $parent or $path eq $parent' unless ( -d $parent or $path eq $parent ) { - push( @created, _mkpath( $arg, [$parent] ) ); + push( @created, _mkpath( $data, [$parent] ) ); } - print "mkdir $path\n" if $arg->{verbose}; - if ( mkdir( $path, $arg->{mode} ) ) { + print "mkdir $path\n" if $data->{verbose}; + if ( mkdir( $path, $data->{mode} ) ) { push( @created, $path ); - if ( exists $arg->{owner} ) { + if ( exists $data->{owner} ) { - # NB: $arg->{group} guaranteed to be set during initialisation - if ( !chown $arg->{owner}, $arg->{group}, $path ) { - _error( $arg, -"Cannot change ownership of $path to $arg->{owner}:$arg->{group}" + # NB: $data->{group} guaranteed to be set during initialisation + if ( !chown $data->{owner}, $data->{group}, $path ) { + _error( $data, + "Cannot change ownership of $path to $data->{owner}:$data->{group}" ); } } - if ( exists $arg->{chmod} ) { - if ( !chmod $arg->{chmod}, $path ) { - _error( $arg, - "Cannot change permissions of $path to $arg->{chmod}" ); + if ( exists $data->{chmod} ) { + # Coverage note: It's not clear how we would trigger the next + # 'if' block. Failure of 'chmod' might first result in a + # system error: "Permission denied". + if ( !chmod $data->{chmod}, $path ) { + _error( $data, + "Cannot change permissions of $path to $data->{chmod}" ); } } } else { my $save_bang = $!; + + # From 'perldoc perlvar': $EXTENDED_OS_ERROR ($^E) is documented + # as: + # Error information specific to the current operating system. At the + # moment, this differs from "$!" under only VMS, OS/2, and Win32 + # (and for MacPerl). On all other platforms, $^E is always just the + # same as $!. + my ( $e, $e1 ) = ( $save_bang, $^E ); $e .= "; $e1" if $e ne $e1; # allow for another process to have created it meanwhile if ( ! -d $path ) { $! = $save_bang; - if ( $arg->{error} ) { - push @{ ${ $arg->{error} } }, { $path => $e }; + if ( $data->{error} ) { + push @{ ${ $data->{error} } }, { $path => $e }; } else { _croak("mkdir $path: $e"); @@ -238,14 +270,13 @@ sub _is_subdir { sub rmtree { my $old_style = !( @_ and __is_arg( $_[-1] ) ); - my $arg; - my $paths; + my ($arg, $data, $paths); if ($old_style) { my ( $verbose, $safe ); ( $paths, $verbose, $safe ) = @_; - $arg->{verbose} = $verbose; - $arg->{safe} = defined $safe ? $safe : 0; + $data->{verbose} = $verbose; + $data->{safe} = defined $safe ? $safe : 0; if ( defined($paths) and length($paths) ) { $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' ); @@ -264,38 +295,53 @@ sub rmtree { verbose | ); my @bad_args = (); - $arg = pop @_; + my $arg = pop @_; for my $k (sort keys %{$arg}) { - push @bad_args, $k unless $args_permitted{$k}; + if (! $args_permitted{$k}) { + push @bad_args, $k; + } + else { + $data->{$k} = $arg->{$k}; + } } _carp("Unrecognized option(s) passed to remove_tree(): @bad_args") if @bad_args; - ${ $arg->{error} } = [] if exists $arg->{error}; - ${ $arg->{result} } = [] if exists $arg->{result}; + ${ $data->{error} } = [] if exists $data->{error}; + ${ $data->{result} } = [] if exists $data->{result}; + + # Wouldn't it make sense to do some validation on @_ before assigning + # to $paths here? + # In the $old_style case we guarantee that each path is both defined + # and non-empty. We don't check that here, which means we have to + # check it later in the first condition in this line: + # if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) { + # Granted, that would be a change in behavior for the two + # non-old-style interfaces. + $paths = [@_]; } - $arg->{prefix} = ''; - $arg->{depth} = 0; + $data->{prefix} = ''; + $data->{depth} = 0; my @clean_path; - $arg->{cwd} = getcwd() or do { - _error( $arg, "cannot fetch initial working directory" ); + $data->{cwd} = getcwd() or do { + _error( $data, "cannot fetch initial working directory" ); return 0; }; - for ( $arg->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint + for ( $data->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint for my $p (@$paths) { # need to fixup case and map \ to / on Windows my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p; my $ortho_cwd = - _IS_MSWIN32 ? _slash_lc( $arg->{cwd} ) : $arg->{cwd}; + _IS_MSWIN32 ? _slash_lc( $data->{cwd} ) : $data->{cwd}; my $ortho_root_length = length($ortho_root); $ortho_root_length-- if _IS_VMS; # don't compare '.' with ']' if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) { local $! = 0; - _error( $arg, "cannot remove path when cwd is $arg->{cwd}", $p ); + _error( $data, "cannot remove path when cwd is $data->{cwd}", $p ); next; } @@ -312,16 +358,16 @@ sub rmtree { push @clean_path, $p; } - @{$arg}{qw(device inode perm)} = ( lstat $arg->{cwd} )[ 0, 1 ] or do { - _error( $arg, "cannot stat initial working directory", $arg->{cwd} ); + @{$data}{qw(device inode)} = ( lstat $data->{cwd} )[ 0, 1 ] or do { + _error( $data, "cannot stat initial working directory", $data->{cwd} ); return 0; }; - return _rmtree( $arg, \@clean_path ); + return _rmtree( $data, \@clean_path ); } sub _rmtree { - my $arg = shift; + my $data = shift; my $paths = shift; my $count = 0; @@ -339,8 +385,8 @@ sub _rmtree { # opposed to being truly canonical, anchored from the root (/). my $canon = - $arg->{prefix} - ? File::Spec->catfile( $arg->{prefix}, $root ) + $data->{prefix} + ? File::Spec->catfile( $data->{prefix}, $root ) : $root; my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ] @@ -354,29 +400,40 @@ sub _rmtree { # see if we can escalate privileges to get in # (e.g. funny protection mask such as -w- instead of rwx) - $perm &= oct '7777'; - my $nperm = $perm | oct '700'; - if ( - !( - $arg->{safe} - or $nperm == $perm - or chmod( $nperm, $root ) - ) - ) - { - _error( $arg, - "cannot make child directory read-write-exec", $canon ); - next ROOT_DIR; + # This uses fchmod to avoid traversing outside of the proper + # location (CVE-2017-6512) + my $root_fh; + if (open($root_fh, '<', $root)) { + my ($fh_dev, $fh_inode) = (stat $root_fh )[0,1]; + $perm &= oct '7777'; + my $nperm = $perm | oct '700'; + local $@; + if ( + !( + $data->{safe} + or $nperm == $perm + or !-d _ + or $fh_dev ne $ldev + or $fh_inode ne $lino + or eval { chmod( $nperm, $root_fh ) } + ) + ) + { + _error( $data, + "cannot make child directory read-write-exec", $canon ); + next ROOT_DIR; + } + close $root_fh; } - elsif ( !chdir($root) ) { - _error( $arg, "cannot chdir to child", $canon ); + if ( !chdir($root) ) { + _error( $data, "cannot chdir to child", $canon ); next ROOT_DIR; } } my ( $cur_dev, $cur_inode, $perm ) = ( stat $curdir )[ 0, 1, 2 ] or do { - _error( $arg, "cannot stat current working directory", $canon ); + _error( $data, "cannot stat current working directory", $canon ); next ROOT_DIR; }; @@ -397,20 +454,20 @@ sub _rmtree { if ( !( - $arg->{safe} + $data->{safe} or $nperm == $perm or chmod( $nperm, $curdir ) ) ) { - _error( $arg, "cannot make directory read+writeable", $canon ); + _error( $data, "cannot make directory read+writeable", $canon ); $nperm = $perm; } my $d; $d = gensym() if $] < 5.006; if ( !opendir $d, $curdir ) { - _error( $arg, "cannot opendir", $canon ); + _error( $data, "cannot opendir", $canon ); @files = (); } else { @@ -437,9 +494,9 @@ sub _rmtree { if (@files) { # remove the contained files before the directory itself - my $narg = {%$arg}; + my $narg = {%$data}; @{$narg}{qw(device inode cwd prefix depth)} = - ( $cur_dev, $cur_inode, $updir, $canon, $arg->{depth} + 1 ); + ( $cur_dev, $cur_inode, $updir, $canon, $data->{depth} + 1 ); $count += _rmtree( $narg, \@files ); } @@ -447,49 +504,49 @@ sub _rmtree { # below fails), while we are still in the directory and may do so # without a race via '.' if ( $nperm != $perm and not chmod( $perm, $curdir ) ) { - _error( $arg, "cannot reset chmod", $canon ); + _error( $data, "cannot reset chmod", $canon ); } # don't leave the client code in an unexpected directory - chdir( $arg->{cwd} ) + chdir( $data->{cwd} ) or - _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting."); + _croak("cannot chdir to $data->{cwd} from $canon: $!, aborting."); # ensure that a chdir upwards didn't take us somewhere other # than we expected (see CVE-2002-0435) ( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ] or _croak( - "cannot stat prior working directory $arg->{cwd}: $!, aborting." + "cannot stat prior working directory $data->{cwd}: $!, aborting." ); if (_NEED_STAT_CHECK) { - ( $arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode ) - or _croak( "previous directory $arg->{cwd} " + ( $data->{device} eq $cur_dev and $data->{inode} eq $cur_inode ) + or _croak( "previous directory $data->{cwd} " . "changed before entering $canon, " . "expected dev=$ldev ino=$lino, " . "actual dev=$cur_dev ino=$cur_inode, aborting." ); } - if ( $arg->{depth} or !$arg->{keep_root} ) { - if ( $arg->{safe} + if ( $data->{depth} or !$data->{keep_root} ) { + if ( $data->{safe} && ( _IS_VMS ? !&VMS::Filespec::candelete($root) : !-w $root ) ) { - print "skipped $root\n" if $arg->{verbose}; + print "skipped $root\n" if $data->{verbose}; next ROOT_DIR; } if ( _FORCE_WRITABLE and !chmod $perm | oct '700', $root ) { - _error( $arg, "cannot make directory writeable", $canon ); + _error( $data, "cannot make directory writeable", $canon ); } - print "rmdir $root\n" if $arg->{verbose}; + print "rmdir $root\n" if $data->{verbose}; if ( rmdir $root ) { - push @{ ${ $arg->{result} } }, $root if $arg->{result}; + push @{ ${ $data->{result} } }, $root if $data->{result}; ++$count; } else { - _error( $arg, "cannot remove directory", $canon ); + _error( $data, "cannot remove directory", $canon ); if ( _FORCE_WRITABLE && !chmod( $perm, @@ -498,7 +555,7 @@ sub _rmtree { ) { _error( - $arg, + $data, sprintf( "cannot restore permissions to 0%o", $perm ), $canon @@ -515,7 +572,7 @@ sub _rmtree { && ( $root !~ m/(?<!\^)[\]>]+/ ); # not already in VMS syntax if ( - $arg->{safe} + $data->{safe} && ( _IS_VMS ? !&VMS::Filespec::candelete($root) @@ -523,7 +580,7 @@ sub _rmtree { ) ) { - print "skipped $root\n" if $arg->{verbose}; + print "skipped $root\n" if $data->{verbose}; next ROOT_DIR; } @@ -532,19 +589,19 @@ sub _rmtree { and $nperm != $perm and not chmod $nperm, $root ) { - _error( $arg, "cannot make file writeable", $canon ); + _error( $data, "cannot make file writeable", $canon ); } - print "unlink $canon\n" if $arg->{verbose}; + print "unlink $canon\n" if $data->{verbose}; # delete all versions under VMS for ( ; ; ) { if ( unlink $root ) { - push @{ ${ $arg->{result} } }, $root if $arg->{result}; + push @{ ${ $data->{result} } }, $root if $data->{result}; } else { - _error( $arg, "cannot unlink file", $canon ); + _error( $data, "cannot unlink file", $canon ); _FORCE_WRITABLE and chmod( $perm, $root ) - or _error( $arg, + or _error( $data, sprintf( "cannot restore permissions to 0%o", $perm ), $canon ); last; @@ -576,41 +633,41 @@ File::Path - Create or remove directory trees =head1 VERSION -This document describes version 2.12 of File::Path. +2.13 - released May 31 2017. =head1 SYNOPSIS - use File::Path qw(make_path remove_tree); - - @created = make_path('foo/bar/baz', '/zug/zwang'); - @created = make_path('foo/bar/baz', '/zug/zwang', { - verbose => 1, - mode => 0711, - }); - make_path('foo/bar/baz', '/zug/zwang', { - chmod => 0777, - }); - - $removed_count = remove_tree('foo/bar/baz', '/zug/zwang'); - $removed_count = remove_tree('foo/bar/baz', '/zug/zwang', { - verbose => 1, - error => \my $err_list, - }); - - # legacy (interface promoted before v2.00) - @created = mkpath('/foo/bar/baz'); - @created = mkpath('/foo/bar/baz', 1, 0711); - @created = mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); - $removed_count = rmtree('foo/bar/baz', 1, 1); - $removed_count = rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); - - # legacy (interface promoted before v2.06) - @created = mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); - $removed_count = rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); + use File::Path qw(make_path remove_tree); + + @created = make_path('foo/bar/baz', '/zug/zwang'); + @created = make_path('foo/bar/baz', '/zug/zwang', { + verbose => 1, + mode => 0711, + }); + make_path('foo/bar/baz', '/zug/zwang', { + chmod => 0777, + }); + + $removed_count = remove_tree('foo/bar/baz', '/zug/zwang', { + verbose => 1, + error => \my $err_list, + safe => 1, + }); + + # legacy (interface promoted before v2.00) + @created = mkpath('/foo/bar/baz'); + @created = mkpath('/foo/bar/baz', 1, 0711); + @created = mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); + $removed_count = rmtree('foo/bar/baz', 1, 1); + $removed_count = rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); + + # legacy (interface promoted before v2.06) + @created = mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); + $removed_count = rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); =head1 DESCRIPTION -This module provide a convenient way to create directories of +This module provides a convenient way to create directories of arbitrary depth and to delete an entire directory subtree from the filesystem. @@ -623,7 +680,7 @@ The following functions are provided: =item make_path( $dir1, $dir2, ...., \%opts ) The C<make_path> function creates the given directories if they don't -exists before, much like the Unix command C<mkdir -p>. +exist before, much like the Unix command C<mkdir -p>. The function accepts a list of directories to be created. Its behaviour may be tuned by an optional hashref appearing as the last @@ -639,7 +696,7 @@ The following keys are recognised in the option hash: =item mode => $num The numeric permissions mode to apply to each created directory -(defaults to 0777), to be modified by the current C<umask>. If the +(defaults to C<0777>), to be modified by the current C<umask>. If the directory already exists (and thus does not need to be created), the permissions will not be modified. @@ -675,9 +732,9 @@ in an C<eval> block. =item uid => $owner If present, will cause any created directory to be owned by C<$owner>. -If the value is numeric, it will be interpreted as a uid, otherwise -as username is assumed. An error will be issued if the username cannot be -mapped to a uid, or the uid does not exist, or the process lacks the +If the value is numeric, it will be interpreted as a uid; otherwise a +username is assumed. An error will be issued if the username cannot be +mapped to a uid, the uid does not exist or the process lacks the privileges to change ownership. Ownership of directories that already exist will not be changed. @@ -686,11 +743,11 @@ C<user> and C<uid> are aliases of C<owner>. =item group => $group -If present, will cause any created directory to be owned by the group C<$group>. -If the value is numeric, it will be interpreted as a gid, otherwise -as group name is assumed. An error will be issued if the group name cannot be -mapped to a gid, or the gid does not exist, or the process lacks the -privileges to change group ownership. +If present, will cause any created directory to be owned by the group +C<$group>. If the value is numeric, it will be interpreted as a gid; +otherwise a group name is assumed. An error will be issued if the +group name cannot be mapped to a gid, the gid does not exist or the +process lacks the privileges to change group ownership. Group ownership of directories that already exist will not be changed. @@ -706,9 +763,10 @@ Group ownership of directories that already exist will not be changed. =item mkpath( $dir1, $dir2,..., \%opt ) -The mkpath() function provide the legacy interface of make_path() with -a different interpretation of the arguments passed. The behaviour and -return value of the function is otherwise identical to make_path(). +The C<mkpath()> function provide the legacy interface of +C<make_path()> with a different interpretation of the arguments +passed. The behaviour and return value of the function is otherwise +identical to C<make_path()>. =item remove_tree( $dir1, $dir2, .... ) @@ -716,16 +774,27 @@ return value of the function is otherwise identical to make_path(). The C<remove_tree> function deletes the given directories and any files and subdirectories they might contain, much like the Unix -command C<rm -r> or the Windows commands C<rmdir /s> and C<rd /s>. The -only exception to the function similarity is C<remove_tree> accepts -only directories whereas C<rm -r> also accepts files. +command C<rm -rf> or the Windows commands C<rmdir /s> and C<rd /s>. The +only exception to the function similarity is that C<remove_tree> accepts +only directories whereas C<rm -rf> also accepts files. The function accepts a list of directories to be removed. Its behaviour may be tuned by an optional hashref appearing as the last parameter on the call. If an empty string is passed to C<remove_tree>, an error will occur. -The functions returns the number of files successfully deleted. +B<NOTE:> For security reasons, we strongly advise use of the +hashref-as-final-argument syntax -- specifically, with a setting of the C<safe> +element to a true value. + + remove_tree( $dir1, $dir2, ...., + { + safe => 1, + ... # other key-value pairs + }, + ); + +The function returns the number of files successfully deleted. The following keys are recognised in the option hash: @@ -751,7 +820,7 @@ When set to a true value, will cause all files and subdirectories to be removed, except the initially specified directories. This comes in handy when cleaning out an application's scratch directory. - remove_tree( '/tmp', {keep_root => 1} ); + remove_tree( '/tmp', {keep_root => 1} ); =item result => \$res @@ -760,8 +829,8 @@ This scalar will be made to reference an array, which will be used to store all files and directories unlinked during the call. If nothing is unlinked, the array will be empty. - remove_tree( '/tmp', {result => \my $list} ); - print "unlinked $_\n" for @$list; + remove_tree( '/tmp', {result => \my $list} ); + print "unlinked $_\n" for @$list; This is a useful alternative to the C<verbose> key. @@ -791,10 +860,21 @@ of hand. This is the safest course of action. =item rmtree( $dir1, $dir2,..., \%opt ) -The rmtree() function provide the legacy interface of remove_tree() -with a different interpretation of the arguments passed. The behaviour -and return value of the function is otherwise identical to -remove_tree(). +The C<rmtree()> function provide the legacy interface of +C<remove_tree()> with a different interpretation of the arguments +passed. The behaviour and return value of the function is otherwise +identical to C<remove_tree()>. + +B<NOTE:> For security reasons, we strongly advise use of the +hashref-as-final-argument syntax, specifically with a setting of the C<safe> +element to a true value. + + rmtree( $dir1, $dir2, ...., + { + safe => 1, + ... # other key-value pairs + }, + ); =back @@ -813,9 +893,9 @@ C<make_path> or C<remove_tree>, you should take additional precautions. =back -If C<make_path> or C<remove_tree> encounter an error, a diagnostic +If C<make_path> or C<remove_tree> encounters an error, a diagnostic message will be printed to C<STDERR> via C<carp> (for non-fatal -errors), or via C<croak> (for fatal errors). +errors) or via C<croak> (for fatal errors). If this behaviour is not desirable, the C<error> attribute may be used to hold a reference to a variable, which will be used to store @@ -828,7 +908,7 @@ encountered the diagnostic key will be empty. An example usage looks like: remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} ); - if (@$err) { + if ($err && @$err) { for my $diag (@$err) { my ($file, $message) = %$diag; if ($file eq '') { @@ -882,16 +962,16 @@ to at least 2.08 in order to avoid surprises. =head3 SECURITY CONSIDERATIONS -There were race conditions 1.x implementations of File::Path's +There were race conditions in the 1.x implementations of File::Path's C<rmtree> function (although sometimes patched depending on the OS distribution or platform). The 2.0 version contains code to avoid the problem mentioned in CVE-2002-0435. See the following pages for more information: - http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905 - http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html - http://www.debian.org/security/2005/dsa-696 + http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905 + http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html + http://www.debian.org/security/2005/dsa-696 Additionally, unless the C<safe> parameter is set (or the third parameter in the traditional interface is TRUE), should a @@ -899,6 +979,27 @@ C<remove_tree> be interrupted, files that were originally in read-only mode may now have their permissions set to a read-write (or "delete OK") mode. +The following CVE reports were previously filed against File-Path and are +believed to have been addressed: + +=over 4 + +=item * L<http://cve.circl.lu/cve/CVE-2004-0452> + +=item * L<http://cve.circl.lu/cve/CVE-2005-0448> + +=back + +In February 2017 the cPanel Security Team reported an additional vulnerability +in File-Path. The C<chmod()> logic to make directories traversable can be +abused to set the mode on an attacker-chosen file to an attacker-chosen value. +This is due to the time-of-check-to-time-of-use (TOCTTOU) race condition +(L<https://en.wikipedia.org/wiki/Time_of_check_to_time_of_use>) between the +C<stat()> that decides the inode is a directory and the C<chmod()> that tries +to make it user-rwx. CPAN versions 2.13 and later incorporate a patch +provided by John Lightsey to address this problem. This vulnerability has +been reported as CVE-2017-6512. + =head1 DIAGNOSTICS FATAL errors will cause the program to halt (C<croak>), since the @@ -907,7 +1008,7 @@ can always be trapped with C<eval>, but it's not a good idea. Under the circumstances, dying is the best thing to do). SEVERE errors may be trapped using the modern interface. If the -they are not trapped, or the old interface is used, such an error +they are not trapped, or if the old interface is used, such an error will cause the program will halt. All other errors may be trapped using the modern interface, otherwise @@ -918,7 +1019,7 @@ they will be C<carp>ed about. Program execution will not be halted. =item mkdir [path]: [errmsg] (SEVERE) C<make_path> was unable to create the path. Probably some sort of -permissions error at the point of departure, or insufficient resources +permissions error at the point of departure or insufficient resources (such as free inodes on Unix). =item No root path(s) specified @@ -997,7 +1098,7 @@ halts to avoid a race condition from occurring. =item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL) -C<remove_tree> was unable to stat the parent directory after have returned +C<remove_tree> was unable to stat the parent directory after having returned from the child. Since there is no way of knowing if we returned to where we think we should be (by comparing device and inode) the only way out is to C<croak>. @@ -1017,9 +1118,9 @@ execution continues, but the directory may possibly not be deleted. =item cannot remove directory [dir]: [errmsg] -C<remove_tree> attempted to remove a directory, but failed. This may because +C<remove_tree> attempted to remove a directory, but failed. This may be because some objects that were unable to be removed remain in the directory, or -a permissions issue. The directory will be left behind. +it could be a permissions issue. The directory will be left behind. =item cannot restore permissions of [dir] to [0nnn]: [errmsg] @@ -1087,14 +1188,16 @@ to examining directory trees. The following describes F<File::Path> limitations and how to report bugs. -=head2 MULTITHREAD APPLICATIONS +=head2 MULTITHREADED APPLICATIONS -F<File::Path> B<rmtree> and B<remove_tree> will not work with multithreaded -applications due to its use of B<chdir>. At this time, no warning or error -results and you will certainly encounter unexpected results. +F<File::Path> C<rmtree> and C<remove_tree> will not work with +multithreaded applications due to its use of C<chdir>. At this time, +no warning or error is generated in this situation. You will +certainly encounter unexpected results. -The implementation that surfaces this limitation may change in a future -release. +The implementation that surfaces this limitation will not be changed. See the +F<File::Path::Tiny> module for functionality similar to F<File::Path> but which does +not C<chdir>. =head2 NFS Mount Points @@ -1147,8 +1250,14 @@ Contributors to File::Path, in alphabetical order. =item <F<bulkdd@cpan.org>> +=item Charlie Gonzalez <F<itcharlie@cpan.org>> + =item Craig A. Berry <F<craigberry@mac.com>> +=item James E Keenan <F<jkeenan@cpan.org>> + +=item John Lightsey <F<john@perlsec.org>> + =item Richard Elberger <F<riche@cpan.org>> =item Ryan Yee <F<ryee@cpan.org>> @@ -1157,12 +1266,14 @@ Contributors to File::Path, in alphabetical order. =item Tom Lutz <F<tommylutz@gmail.com>> +=item Will Sheppard <F<willsheppard@github>> + =back =head1 COPYRIGHT This module is copyright (C) Charles Bailey, Tim Bunce, David Landgren, -James Keenan, and Richard Elberger 1995-2015. All rights reserved. +James Keenan and Richard Elberger 1995-2017. All rights reserved. =head1 LICENSE diff --git a/gnu/usr.bin/perl/cpan/File-Path/t/FilePathTest.pm b/gnu/usr.bin/perl/cpan/File-Path/t/FilePathTest.pm index f9e82893119..88b411d4bb3 100644 --- a/gnu/usr.bin/perl/cpan/File-Path/t/FilePathTest.pm +++ b/gnu/usr.bin/perl/cpan/File-Path/t/FilePathTest.pm @@ -3,18 +3,26 @@ use strict; use warnings; use base 'Exporter'; use SelectSaver; +use Carp; use Cwd; use File::Spec::Functions; +use File::Path (); +use Test::More (); -our @EXPORT = qw(_run_for_warning _run_for_verbose _basedir - _cannot_delete_safe_mode - _verbose_expected); +our @EXPORT_OK = qw( + _run_for_warning + _run_for_verbose + _cannot_delete_safe_mode + _verbose_expected + create_3_level_subdirs + cleanup_3_level_subdirs +); sub _basedir { - return catdir( curdir(), - sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ), + return catdir( + curdir(), + sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ), ); - } sub _run_for_warning { @@ -109,4 +117,28 @@ END } } +sub create_3_level_subdirs { + my @dirnames = @_; + my %seen = map {$_ => 1} @dirnames; + croak "Need 3 distinct names for subdirectories" + unless scalar(keys %seen) == 3; + my $tdir = File::Spec::Functions::tmpdir(); + my $least_deep = catdir($tdir, $dirnames[0]); + my $next_deepest = catdir($least_deep, $dirnames[1]); + my $deepest = catdir($next_deepest, $dirnames[2]); + return ($least_deep, $next_deepest, $deepest); +} + +sub cleanup_3_level_subdirs { + # runs 2 tests + my $least_deep = shift; + croak "Must provide path of least subdirectory" + unless (length($least_deep) and (-d $least_deep)); + my $x; + my $opts = { error => \$x }; + File::Path::remove_tree($least_deep, $opts); + Test::More::ok(! -d $least_deep, "directory '$least_deep' removed, as expected"); + Test::More::is(scalar(@{$x}), 0, "no error messages using remove_tree() with \$opts"); +} + 1; diff --git a/gnu/usr.bin/perl/cpan/File-Path/t/Path-Class.t b/gnu/usr.bin/perl/cpan/File-Path/t/Path-Class.t new file mode 100644 index 00000000000..d896fbbf553 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/File-Path/t/Path-Class.t @@ -0,0 +1,50 @@ +use strict; +use warnings; +use Test::More tests => 32; + +eval "require Path::Class"; + + +SKIP: { + skip "Path::Class required to run this test", 32 if $@; + use File::Path qw(remove_tree make_path); + Path::Class->import; + + my $name = 'test'; + my $dir = dir($name); + + for my $mk_dir ($name, dir($name)) { + for my $mk_pass_arg (0, 1) { + + for my $rm_dir ($name, dir($name)) { + for my $rm_pass_arg (0, 1) { + remove_tree($name) if -e $name; + + my ($mk_args, $mk_desc) = test($mk_dir, $mk_pass_arg); + make_path(@$mk_args); + + if (ok( -d $dir, "we made $dir ($mk_desc)")) { + my ($rm_args, $rm_desc) = test($rm_dir, $rm_pass_arg); + remove_tree(@$rm_args); + ok( ! -d $dir, "...then we removed $dir ($rm_desc)"); + } else { + fail("...can't remove it if we didn't create it"); + } + } + } + } + } +} + +sub test { + my ($dir, $pass_arg) = @_; + + my $args = [ $dir, ($pass_arg ? {} : ()) ]; + my $desc = sprintf( + 'dir isa %s, second arg is %s', + (ref($dir) || 'string'), + ($pass_arg ? '{}' : 'not passed') + ); + + return ($args, $desc); +} diff --git a/gnu/usr.bin/perl/cpan/File-Path/t/Path.t b/gnu/usr.bin/perl/cpan/File-Path/t/Path.t index 5644f57a516..9be39a5de2f 100755 --- a/gnu/usr.bin/perl/cpan/File-Path/t/Path.t +++ b/gnu/usr.bin/perl/cpan/File-Path/t/Path.t @@ -3,11 +3,20 @@ use strict; -use Test::More tests => 127; +use Test::More tests => 167; use Config; use Fcntl ':mode'; -use lib 't/'; -use FilePathTest; +use lib './t'; +use FilePathTest qw( + _run_for_warning + _run_for_verbose + _cannot_delete_safe_mode + _verbose_expected + create_3_level_subdirs + cleanup_3_level_subdirs +); +use Errno qw(:POSIX); +use Carp; BEGIN { use_ok('Cwd'); @@ -17,6 +26,13 @@ BEGIN { my $Is_VMS = $^O eq 'VMS'; +my $fchmod_supported = 0; +if (open my $fh, curdir()) { + my ($perm) = (stat($fh))[2]; + $perm &= 07777; + eval { $fchmod_supported = chmod( $perm, $fh); }; +} + # first check for stupid permissions second for full, so we clean up # behind ourselves for my $perm (0111,0777) { @@ -298,16 +314,19 @@ is($created[0], $dir, "created directory (old style 3 mode undef) cross-check"); is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef"); -$dir = catdir($tmp_base,'G'); -$dir = VMS::Filespec::unixify($dir) if $Is_VMS; +SKIP: { + skip "fchmod of directories not supported on this platform", 3 unless $fchmod_supported; + $dir = catdir($tmp_base,'G'); + $dir = VMS::Filespec::unixify($dir) if $Is_VMS; -@created = mkpath($dir, undef, 0200); + @created = mkpath($dir, undef, 0400); -is(scalar(@created), 1, "created write-only dir"); + is(scalar(@created), 1, "created read-only dir"); -is($created[0], $dir, "created write-only directory cross-check"); + is($created[0], $dir, "created read-only directory cross-check"); -is(rmtree($dir), 1, "removed write-only dir"); + is(rmtree($dir), 1, "removed read-only dir"); +} # borderline new-style heuristics if (chdir $tmp_base) { @@ -449,26 +468,28 @@ SKIP: { } SKIP : { - my $skip_count = 19; + my $skip_count = 18; # this test will fail on Windows, as per: # http://perldoc.perl.org/perlport.html#chmod skip "Windows chmod test skipped", $skip_count if $^O eq 'MSWin32'; + skip "fchmod() on directories is not supported on this platform", $skip_count + unless $fchmod_supported; my $mode; my $octal_mode; my @inputs = ( - 0777, 0700, 0070, 0007, - 0333, 0300, 0030, 0003, - 0111, 0100, 0010, 0001, - 0731, 0713, 0317, 0371, 0173, 0137, - 00 ); + 0777, 0700, 0470, 0407, + 0433, 0400, 0430, 0403, + 0111, 0100, 0110, 0101, + 0731, 0713, 0317, 0371, + 0173, 0137); my $input; my $octal_input; - $dir = catdir($tmp_base, 'chmod_test'); foreach (@inputs) { $input = $_; + $dir = catdir($tmp_base, sprintf("chmod_test%04o", $input)); # We can skip from here because 0 is last in the list. skip "Mode of 0 means assume user defaults on VMS", 1 if ($input == 0 && $Is_VMS); @@ -476,7 +497,11 @@ SKIP : { $mode = (stat($dir))[2]; $octal_mode = S_IMODE($mode); $octal_input = sprintf "%04o", S_IMODE($input); - is($octal_mode,$input, "create a new directory with chmod $input ($octal_input)"); + SKIP: { + skip "permissions are not fully supported by the filesystem", 1 + if (($^O eq 'MSWin32' || $^O eq 'cygwin') && ((Win32::FsType())[1] & 8) == 0); + is($octal_mode,$input, "create a new directory with chmod $input ($octal_input)"); + } rmtree( $dir ); } } @@ -587,29 +612,27 @@ SKIP: { my $dir2 = catdir( $base, 'B'); { - my $warn; - $SIG{__WARN__} = sub { $warn = shift }; - - my @created = make_path( - $dir, - $dir2, - { mode => 0711, foo => 1, bar => 1 } - ); + my $warn = _run_for_warning( sub { + my @created = make_path( + $dir, + $dir2, + { mode => 0711, foo => 1, bar => 1 } + ); + } ); like($warn, - qr/Unrecognized option\(s\) passed to make_path\(\):.*?bar.*?foo/, + qr/Unrecognized option\(s\) passed to mkpath\(\) or make_path\(\):.*?bar.*?foo/, 'make_path with final hashref warned due to unrecognized options' ); } { - my $warn; - $SIG{__WARN__} = sub { $warn = shift }; - - my @created = remove_tree( - $dir, - $dir2, - { foo => 1, bar => 1 } - ); + my $warn = _run_for_warning( sub { + my @created = remove_tree( + $dir, + $dir2, + { foo => 1, bar => 1 } + ); + } ); like($warn, qr/Unrecognized option\(s\) passed to remove_tree\(\):.*?bar.*?foo/, 'remove_tree with final hashref failed due to unrecognized options' @@ -656,7 +679,7 @@ is( { my ($x, $message, $object, $expect, $rv, $arg, $error); my ($k, $v, $second_error, $third_error); - local $! = 2; + local $! = ENOENT; $x = $!; $message = 'message in a bottle'; @@ -729,3 +752,186 @@ is( is($k, '', "key of hash is empty string, since 3rd arg was undef"); is($v, $expect, "value of hash is 2nd arg: $message"); } + +{ + # https://rt.cpan.org/Ticket/Display.html?id=117019 + # remove_tree(): Permit re-use of options hash without issuing a warning + + my ($least_deep, $next_deepest, $deepest) = + create_3_level_subdirs( qw| a b c | ); + my @created; + @created = File::Path::make_path($deepest, { mode => 0711 }); + is(scalar(@created), 3, "Created 3 subdirectories"); + + my $x = ''; + my $opts = { error => \$x }; + File::Path::remove_tree($deepest, $opts); + ok(! -d $deepest, "directory '$deepest' removed, as expected"); + + my $warn; + $warn = _run_for_warning( sub { File::Path::remove_tree($next_deepest, $opts); } ); + ok(! $warn, "CPAN 117019: No warning thrown when re-using \$opts"); + ok(! -d $next_deepest, "directory '$next_deepest' removed, as expected"); + + $warn = _run_for_warning( sub { File::Path::remove_tree($least_deep, $opts); } ); + ok(! $warn, "CPAN 117019: No warning thrown when re-using \$opts"); + ok(! -d $least_deep, "directory '$least_deep' removed, as expected"); +} + +{ + # Corner cases with respect to arguments provided to functions + my $count; + + $count = remove_tree(); + is($count, 0, + "If not provided with any paths, remove_tree() will return a count of 0 things deleted"); + + $count = remove_tree(''); + is($count, 0, + "If not provided with any paths, remove_tree() will return a count of 0 things deleted"); + + my $warn; + $warn = _run_for_warning( sub { $count = rmtree(); } ); + like($warn, qr/No root path\(s\) specified/s, "Got expected carp"); + is($count, 0, + "If not provided with any paths, remove_tree() will return a count of 0 things deleted"); + + $warn = _run_for_warning( sub {$count = rmtree(undef); } ); + like($warn, qr/No root path\(s\) specified/s, "Got expected carp"); + is($count, 0, + "If provided only with an undefined value, remove_tree() will return a count of 0 things deleted"); + + $warn = _run_for_warning( sub {$count = rmtree(''); } ); + like($warn, qr/No root path\(s\) specified/s, "Got expected carp"); + is($count, 0, + "If provided with an empty string for a path, remove_tree() will return a count of 0 things deleted"); + + $count = make_path(); + is($count, 0, + "If not provided with any paths, make_path() will return a count of 0 things created"); + + $count = mkpath(); + is($count, 0, + "If not provided with any paths, make_path() will return a count of 0 things created"); +} + +SKIP: { + my $skip_count = 5; + skip "Windows will not set this error condition", $skip_count + if $^O eq 'MSWin32'; + + # mkpath() with hashref: case of phony user + my ($least_deep, $next_deepest, $deepest) = + create_3_level_subdirs( qw| d e f | ); + my (@created, $error); + my $user = join('_' => 'foobar', $$); + @created = mkpath($deepest, { mode => 0711, user => $user, error => \$error }); + TODO: { + local $TODO = "Notwithstanding the phony 'user', mkpath will actually create subdirectories; should it?"; + is(scalar(@created), 0, "No subdirectories created"); + } + is(scalar(@$error), 1, "caught error condition" ); + my ($file, $message) = each %{$error->[0]}; + like($message, + qr/unable to map $user to a uid, ownership not changed/s, + "Got expected error message for phony user", + ); + + cleanup_3_level_subdirs($least_deep); +} + +{ + # mkpath() with hashref: case of valid uid + my ($least_deep, $next_deepest, $deepest) = + create_3_level_subdirs( qw| j k l | ); + my (@created, $error); + @created = mkpath($deepest, { mode => 0711, uid => $>, error => \$error }); + is(scalar(@created), 3, "Provide valid 'uid' argument: 3 subdirectories created"); + + cleanup_3_level_subdirs($least_deep); +} + +SKIP: { + my $skip_count = 3; + skip "getpwuid() and getgrgid() not implemented on Windows", $skip_count + if $^O eq 'MSWin32'; + + # mkpath() with hashref: case of valid owner + my ($least_deep, $next_deepest, $deepest) = + create_3_level_subdirs( qw| m n o | ); + my (@created, $error); + my $name = getpwuid($>); + @created = mkpath($deepest, { mode => 0711, owner => $name, error => \$error }); + is(scalar(@created), 3, "Provide valid 'owner' argument: 3 subdirectories created"); + + cleanup_3_level_subdirs($least_deep); +} + +SKIP: { + my $skip_count = 5; + skip "Windows will not set this error condition", $skip_count + if $^O eq 'MSWin32'; + + # mkpath() with hashref: case of phony group + my ($least_deep, $next_deepest, $deepest) = + create_3_level_subdirs( qw| p q r | ); + my (@created, $error); + my $bad_group = join('_' => 'foobarbaz', $$); + @created = mkpath($deepest, { mode => 0711, group => $bad_group, error => \$error }); + TODO: { + local $TODO = "Notwithstanding the phony 'group', mkpath will actually create subdirectories; should it?"; + is(scalar(@created), 0, "No subdirectories created"); + } + is(scalar(@$error), 1, "caught error condition" ); + my ($file, $message) = each %{$error->[0]}; + like($message, + qr/unable to map $bad_group to a gid, group ownership not changed/s, + "Got expected error message for phony user", + ); + + cleanup_3_level_subdirs($least_deep); +} + +{ + # mkpath() with hashref: case of valid group + my ($least_deep, $next_deepest, $deepest) = + create_3_level_subdirs( qw| s t u | ); + my (@created, $error); + @created = mkpath($deepest, { mode => 0711, group => $(, error => \$error }); + is(scalar(@created), 3, "Provide valid 'group' argument: 3 subdirectories created"); + + cleanup_3_level_subdirs($least_deep); +} + +SKIP: { + my $skip_count = 3; + skip "getpwuid() and getgrgid() not implemented on Windows", $skip_count + if $^O eq 'MSWin32'; + + # mkpath() with hashref: case of valid group + my ($least_deep, $next_deepest, $deepest) = + create_3_level_subdirs( qw| v w x | ); + my (@created, $error); + my $group_name = (getgrgid($())[0]; + @created = mkpath($deepest, { mode => 0711, group => $group_name, error => \$error }); + is(scalar(@created), 3, "Provide valid 'group' argument: 3 subdirectories created"); + + cleanup_3_level_subdirs($least_deep); +} + +SKIP: { + my $skip_count = 3; + skip "getpwuid() and getgrgid() not implemented on Windows", $skip_count + if $^O eq 'MSWin32'; + + # mkpath() with hashref: case of valid owner and group + my ($least_deep, $next_deepest, $deepest) = + create_3_level_subdirs( qw| delta epsilon zeta | ); + my (@created, $error); + my $name = getpwuid($>); + my $group_name = (getgrgid($())[0]; + @created = mkpath($deepest, { mode => 0711, owner => $name, group => $group_name, error => \$error }); + is(scalar(@created), 3, "Provide valid 'owner' and 'group' 'group' arguments: 3 subdirectories created"); + + cleanup_3_level_subdirs($least_deep); +} diff --git a/gnu/usr.bin/perl/cpan/File-Path/t/Path_root.t b/gnu/usr.bin/perl/cpan/File-Path/t/Path_root.t index 36aeb1677de..2647b7fd121 100644 --- a/gnu/usr.bin/perl/cpan/File-Path/t/Path_root.t +++ b/gnu/usr.bin/perl/cpan/File-Path/t/Path_root.t @@ -1,15 +1,17 @@ use strict; use Test::More; use Config; -use lib 't/'; -use FilePathTest; +use lib './t'; +use FilePathTest qw( + _run_for_warning +); use File::Path qw(rmtree mkpath make_path remove_tree); use File::Spec::Functions; my $prereq = prereq(); plan skip_all => $prereq if defined $prereq; -plan tests => 8; +plan tests => 11; my $pwent = max_u(); my $grent = max_g(); @@ -60,21 +62,35 @@ is(scalar(@created), 1, "created a directory owned by $max_user:$max_group..."); is($dir_uid, $max_uid, "... owned by $max_uid"); is($dir_gid, $max_gid, "... owned by group $max_gid"); -SKIP: { - skip('Skip until RT 85878 is fixed', 1); +{ # invent a user and group that don't exist do { ++$max_user } while ( getpwnam( $max_user ) ); do { ++$max_group } while ( getgrnam( $max_group ) ); $dir = catdir($dir_stem, 'aad'); - my $rv = _run_for_warning( sub { make_path( $dir, - { user => $max_user, - group => $max_group } ) } ); + my $rv = _run_for_warning( sub { + make_path( + $dir, + { user => $max_user, group => $max_group } + ) + } ); + like( $rv, + qr{unable to map $max_user to a uid, ownership not changed:}s, + "created a directory not owned by $max_user:$max_group...", + ); like( $rv, - qr{\Aunable to map $max_user to a uid, ownership not changed: .* at \S+ line \d+ -unable to map $max_group to a gid, group ownership not changed: .* at \S+ line \d+\b}, - "created a directory not owned by $max_user:$max_group..." - ); + qr{unable to map $max_group to a gid, group ownership not changed:}s, + "created a directory not owned by $max_user:$max_group...", + ); +} + +{ + # cleanup + my $x; + my $opts = { error => \$x }; + remove_tree($tmp_base, $opts); + ok(! -d $tmp_base, "directory '$tmp_base' removed, as expected"); + is(scalar(@{$x}), 0, "no error messages using remove_tree() with \$opts"); } sub max_u { diff --git a/gnu/usr.bin/perl/cpan/File-Path/t/Path_win32.t b/gnu/usr.bin/perl/cpan/File-Path/t/Path_win32.t index 47168822b96..89b0b2f045c 100644 --- a/gnu/usr.bin/perl/cpan/File-Path/t/Path_win32.t +++ b/gnu/usr.bin/perl/cpan/File-Path/t/Path_win32.t @@ -1,16 +1,20 @@ use strict; use Test::More; -use lib 't/'; -use FilePathTest; +use lib './t'; +use FilePathTest qw( + create_3_level_subdirs + cleanup_3_level_subdirs +); use File::Path; use Cwd; use File::Spec::Functions; +use Carp; plan skip_all => 'not win32' unless $^O eq 'MSWin32'; my ($ignore, $major, $minor, $build, $id) = Win32::GetOSVersion(); plan skip_all => "WinXP or later" unless $id >= 2 && ($major > 5 || $major == 5 && $minor >= 1); -plan tests => 3; +plan tests => 9; my $tmp_base = catdir( curdir(), @@ -30,3 +34,29 @@ ok(-d $UNC_path, 'mkpath on Win32 UNC path made dir'); my $removed = rmtree($UNC_path); cmp_ok($removed, '>', 0, "removed $removed entries from $UNC_path"); + +{ + my ($least_deep, $next_deepest, $deepest) = + create_3_level_subdirs( qw| d e f | ); + my (@created, $error); + my $user = join('_' => 'foobar', $$); + { + my $warn; + $SIG{__WARN__} = sub { $warn = shift }; + + @created = mkpath($deepest, { mode => 0711, user => $user, error => \$error }); + like($warn, + qr/Option\(s\) implausible on Win32 passed to mkpath\(\) or make_path\(\)/, + 'make_path with final hashref warned due to options implausible on Win32' + ); + TODO: { + local $TODO = "Notwithstanding the Win32-implausible 'user', mkpath will actually create subdirectories; should it?"; + is(scalar(@created), 0, "No subdirectories created"); + } + is(scalar(@created), 3, "3 subdirectories created"); + is(scalar(@$error), 0, "no error condition" ); + } + + cleanup_3_level_subdirs($least_deep); +} + diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/private/MakeUtil.pm b/gnu/usr.bin/perl/cpan/IO-Compress/private/MakeUtil.pm index 47aebd60743..9d7e5ed262d 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/private/MakeUtil.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/private/MakeUtil.pm @@ -35,7 +35,8 @@ sub MY::libscan my $path = shift; return undef - if $path =~ /(~|\.bak|_bak)$/ || + if $path =~ /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/ || + $path =~ /(~|\.bak|_bak)$/ || $path =~ /\..*\.sw(o|p)$/ || $path =~ /\B\.svn\b/; diff --git a/gnu/usr.bin/perl/cpan/NEXT/lib/NEXT.pm b/gnu/usr.bin/perl/cpan/NEXT/lib/NEXT.pm index a77bb387433..72dbee8c51c 100644 --- a/gnu/usr.bin/perl/cpan/NEXT/lib/NEXT.pm +++ b/gnu/usr.bin/perl/cpan/NEXT/lib/NEXT.pm @@ -190,7 +190,7 @@ __END__ =head1 NAME -NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch +NEXT - Provide a pseudo-class NEXT (et al) that allows method redispatch =head1 SYNOPSIS diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/PlainText.pm b/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/PlainText.pm index 3db4d903cd6..03252e93c71 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/PlainText.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/PlainText.pm @@ -139,6 +139,19 @@ sub initialize { return $self->SUPER::initialize; } +# pod2text and pod2man re-use the same parser on a list of files, +# and will lose some information if some intermediate documents produce +# unbalanced calls to begin_cmd/end_cmd. +# via r1.4 of OpenBSD src/gnu/usr.bin/perl/lib/Pod/PlainText.pm +sub begin_pod { + my $self = shift; + + $$self{VERBATIM} = 0; + $$self{EXCLUDE} = 0; + + return $self->SUPER::begin_pod(@_); +} + ############################################################################ # Core overrides diff --git a/gnu/usr.bin/perl/cpan/Sys-Syslog/Makefile.PL b/gnu/usr.bin/perl/cpan/Sys-Syslog/Makefile.PL index 347197ab440..fce84965200 100644 --- a/gnu/usr.bin/perl/cpan/Sys-Syslog/Makefile.PL +++ b/gnu/usr.bin/perl/cpan/Sys-Syslog/Makefile.PL @@ -13,7 +13,7 @@ if ($] < 5.008) { } # create a lib/ dir in order to avoid warnings in Test::Distribution -mkdir "lib", 0755; +mkdir "lib", $ENV{PERL_CORE} ? 0770 : 0755; # virtual paths given to EU::MM my %virtual_path = ( 'Syslog.pm' => '$(INST_LIBDIR)/Syslog.pm' ); diff --git a/gnu/usr.bin/perl/cpan/Text-Balanced/lib/Text/Balanced.pm b/gnu/usr.bin/perl/cpan/Text-Balanced/lib/Text/Balanced.pm index f1a5780a0b9..4fbb1bc6315 100644 --- a/gnu/usr.bin/perl/cpan/Text-Balanced/lib/Text/Balanced.pm +++ b/gnu/usr.bin/perl/cpan/Text-Balanced/lib/Text/Balanced.pm @@ -1508,7 +1508,7 @@ C<extract_tagged> returns the complete text up to the point of failure. If the string is "PARA", C<extract_tagged> returns only the first paragraph after the tag (up to the first line that is either empty or contains only whitespace characters). -If the string is "", the the default behaviour (i.e. failure) is reinstated. +If the string is "", the default behaviour (i.e. failure) is reinstated. For example, suppose the start tag "/para" introduces a paragraph, which then continues until the next "/endpara" tag or until another "/para" tag is diff --git a/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Man.pm b/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Man.pm index b739559551d..f014b3183e9 100644 --- a/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Man.pm +++ b/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Man.pm @@ -896,6 +896,8 @@ sub devise_title { $cut = $i + 1; $cut++ if ($dirs[$i + 1] && $dirs[$i + 1] eq 'lib'); last; + } elsif ($dirs[$i] eq 'lib' && $dirs[$i + 1] && $dirs[0] eq 'ext') { + $cut = $i + 1; } } if ($cut > 0) { diff --git a/gnu/usr.bin/perl/cpan/podlators/scripts/pod2man.PL b/gnu/usr.bin/perl/cpan/podlators/scripts/pod2man.PL index f40c126e562..ea7070f7d63 100644 --- a/gnu/usr.bin/perl/cpan/podlators/scripts/pod2man.PL +++ b/gnu/usr.bin/perl/cpan/podlators/scripts/pod2man.PL @@ -77,7 +77,7 @@ Getopt::Long::config ('bundling_override'); GetOptions (\%options, 'center|c=s', 'date|d=s', 'errors=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s', 'fixedbolditalic=s', 'help|h', 'lax|l', 'name|n=s', 'nourls', 'official|o', 'quotes|q=s', - 'release|r=s', 'section|s=s', 'stderr', 'verbose|v', 'utf8|u') + 'release|r=s', 'section|s=s', 'stderr', 'verbose|v', 'utf8|u!') or exit 1; pod2usage (0) if $options{help}; @@ -123,7 +123,7 @@ exit $status; __END__ =for stopwords -en em --stderr stderr --utf8 UTF-8 overdo markup MT-LEVEL Allbery Solaris +en em --stderr stderr --no-utf8 UTF-8 overdo markup MT-LEVEL Allbery Solaris URL troff troff-specific formatters uppercased Christiansen --nourls UTC prepend @@ -137,7 +137,7 @@ pod2man [B<--center>=I<string>] [B<--date>=I<string>] [B<--errors>=I<style>] [B<--fixed>=I<font>] [B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>] [B<--fixedbolditalic>=I<font>] [B<--name>=I<name>] [B<--nourls>] [B<--official>] [B<--quotes>=I<quotes>] [B<--release>=I<version>] - [B<--section>=I<manext>] [B<--stderr>] [B<--utf8>] [B<--verbose>] + [B<--section>=I<manext>] [B<--stderr>] [B<--no-utf8>] [B<--verbose>] [I<input> [I<output>] ...] pod2man B<--help> @@ -323,19 +323,10 @@ to C<--errors=stderr> and is supported for backward compatibility. =item B<-u>, B<--utf8> -By default, B<pod2man> produces the most conservative possible *roff -output to try to ensure that it will work with as many different *roff -implementations as possible. Many *roff implementations cannot handle -non-ASCII characters, so this means all non-ASCII characters are converted -either to a *roff escape sequence that tries to create a properly accented -character (at least for troff output) or to C<X>. - -This option says to instead output literal UTF-8 characters. If your -*roff implementation can handle it, this is the best output format to use -and avoids corruption of documents containing non-ASCII characters. -However, be warned that *roff source with literal UTF-8 characters is not -supported by many implementations and may even result in segfaults and -other bad behavior. +This option allows B<pod2man> to output literal UTF-8 characters. +On OpenBSD, it is enabled by default and can be disabled with +B<--no-utf8>, in which case non-ASCII characters are converted +either to *roff escape sequences or to C<X>. Be aware that, when using this option, the input encoding of your POD source should be properly declared unless it's US-ASCII. Pod::Simple will diff --git a/gnu/usr.bin/perl/deb.c b/gnu/usr.bin/perl/deb.c index 02a0a7d17ce..37dcdded903 100644 --- a/gnu/usr.bin/perl/deb.c +++ b/gnu/usr.bin/perl/deb.c @@ -234,7 +234,7 @@ Perl_deb_stack_all(pTHX) PerlIO_printf(Perl_debug_log, "\n"); else { - /* Find the the current context's stack range by searching + /* Find the current context's stack range by searching * forward for any higher contexts using this stack; failing * that, it will be equal to the size of the stack for old * stacks, or PL_stack_sp for the current stack diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.pm b/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.pm index ad9a65c99d2..2071e5e83dc 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.pm +++ b/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.pm @@ -23,12 +23,12 @@ our @EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF TIMER_ABSTIME d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer - d_nanosleep d_clock_gettime d_clock_getres + d_nanosleep d_clock_gettime d_clock_getres d_hires_utime d_clock d_clock_nanosleep - stat lstat + stat lstat utime ); -our $VERSION = '1.9733'; +our $VERSION = '1.9739'; our $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -60,6 +60,7 @@ sub import { ($i eq 'clock' && !&d_clock) || ($i eq 'nanosleep' && !&d_nanosleep) || ($i eq 'usleep' && !&d_usleep) || + ($i eq 'utime' && !&d_hires_utime) || ($i eq 'ualarm' && !&d_ualarm)) { require Carp; Carp::croak("Time::HiRes::$i(): unimplemented in this platform"); @@ -92,7 +93,7 @@ Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep clock_gettime clock_getres clock_nanosleep clock - stat lstat ); + stat lstat utime); usleep ($microseconds); nanosleep ($nanoseconds); @@ -137,6 +138,9 @@ Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers my @stat = stat(FH); my @stat = lstat("file"); + use Time::HiRes qw( utime ); + utime $floating_seconds, $floating_seconds, file...; + =head1 DESCRIPTION The C<Time::HiRes> module implements a Perl interface to the @@ -446,6 +450,26 @@ if the operations are the access time stamp from t2 need not be greater-than the modify time stamp from t1: it may be equal or I<less>. +=item utime LIST + +As L<perlfunc/utime> +but with the ability to set the access/modify file timestamps +in subsecond resolution, if the operating system and the filesystem +both support such timestamps. To override the standard utime(): + + use Time::HiRes qw(utime); + +Test for the value of &Time::HiRes::d_hires_utime to find out whether +the operating system supports setting subsecond file timestamps. + +As with CORE::utime(), passing undef as both the atime and mtime will +call the syscall with a NULL argument. + +The actual achievable subsecond resolution depends on the combination +of the operating system and the filesystem. + +Returns the number of files successfully changed. + =back =head1 EXAMPLES @@ -586,9 +610,13 @@ might help in this (in case your system supports CLOCK_MONOTONIC). Some systems have APIs but not implementations: for example QNX and Haiku have the interval timer APIs but not the functionality. -In OS X clock_getres(), clock_gettime() and clock_nanosleep() are -emulated using the Mach timers; as a side effect of being emulated -the CLOCK_REALTIME and CLOCK_MONOTONIC are the same timer. +In pre-Sierra macOS (pre-10.12, OS X) clock_getres(), clock_gettime() +and clock_nanosleep() are emulated using the Mach timers; as a side +effect of being emulated the CLOCK_REALTIME and CLOCK_MONOTONIC are +the same timer. + +gnukfreebsd seems to have non-functional futimens() and utimensat() +(at least as of 10.1): therefore the hires utime() does not work. =head1 SEE ALSO diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.xs b/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.xs index 38ca0dc3204..3a5c7a1d63c 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.xs +++ b/gnu/usr.bin/perl/dist/Time-HiRes/HiRes.xs @@ -747,21 +747,33 @@ hrstatns(UV *atime_nsec, UV *mtime_nsec, UV *ctime_nsec) #endif /* !TIME_HIRES_STAT */ } -/* Until Apple implements clock_gettime() (ditto clock_getres()) - * we will emulate it using Mach interfaces. */ -#if defined(PERL_DARWIN) && !defined(CLOCK_REALTIME) - -# include <mach/mach_time.h> - +/* Until Apple implements clock_gettime() + * (ditto clock_getres() and clock_nanosleep()) + * we will emulate them using the Mach kernel interfaces. */ +#if defined(PERL_DARWIN) && \ + (defined(TIME_HIRES_CLOCK_GETTIME_EMULATION) || \ + defined(TIME_HIRES_CLOCK_GETRES_EMULATION) || \ + defined(TIME_HIRES_CLOCK_NANOSLEEP_EMULATION)) + +#ifndef CLOCK_REALTIME # define CLOCK_REALTIME 0x01 # define CLOCK_MONOTONIC 0x02 +#endif +#ifndef TIMER_ABSTIME # define TIMER_ABSTIME 0x01 +#endif #ifdef USE_ITHREADS +# define PERL_DARWIN_MUTEX +#endif + +#ifdef PERL_DARWIN_MUTEX STATIC perl_mutex darwin_time_mutex; #endif +#include <mach/mach_time.h> + static uint64_t absolute_time_init; static mach_timebase_info_data_t timebase_info; static struct timespec timespec_init; @@ -769,7 +781,7 @@ static struct timespec timespec_init; static int darwin_time_init() { struct timeval tv; int success = 1; -#ifdef USE_ITHREADS +#ifdef PERL_DARWIN_MUTEX MUTEX_LOCK(&darwin_time_mutex); #endif if (absolute_time_init == 0) { @@ -784,12 +796,13 @@ static int darwin_time_init() { } } } -#ifdef USE_ITHREADS +#ifdef PERL_DARWIN_MUTEX MUTEX_UNLOCK(&darwin_time_mutex); #endif return success; } +#ifdef TIME_HIRES_CLOCK_GETTIME_EMULATION static int clock_gettime(int clock_id, struct timespec *ts) { if (darwin_time_init() && timebase_info.denom) { switch (clock_id) { @@ -821,7 +834,9 @@ static int clock_gettime(int clock_id, struct timespec *ts) { SETERRNO(EINVAL, LIB_INVARG); return -1; } +#endif /* TIME_HIRES_CLOCK_GETTIME_EMULATION */ +#ifdef TIME_HIRES_CLOCK_GETRES_EMULATION static int clock_getres(int clock_id, struct timespec *ts) { if (darwin_time_init() && timebase_info.denom) { switch (clock_id) { @@ -841,7 +856,9 @@ static int clock_getres(int clock_id, struct timespec *ts) { SETERRNO(EINVAL, LIB_INVARG); return -1; } +#endif /* TIME_HIRES_CLOCK_GETRES_EMULATION */ +#ifdef TIME_HIRES_CLOCK_NANOSLEEP_EMULATION static int clock_nanosleep(int clock_id, int flags, const struct timespec *rqtp, struct timespec *rmtp) { @@ -879,6 +896,7 @@ static int clock_nanosleep(int clock_id, int flags, SETERRNO(EINVAL, LIB_INVARG); return -1; } +#endif /* TIME_HIRES_CLOCK_NANOSLEEP_EMULATION */ #endif /* PERL_DARWIN */ @@ -921,6 +939,22 @@ nsec_without_unslept(struct timespec *sleepfor, #endif +/* In case Perl and/or Devel::PPPort are too old, minimally emulate + * IS_SAFE_PATHNAME() (which looks for zero bytes in the pathname). */ +#ifndef IS_SAFE_PATHNAME +#if PERL_VERSION >= 12 /* Perl_ck_warner is 5.10.0 -> */ +#ifdef WARN_SYSCALLS +#define WARNEMUCAT WARN_SYSCALLS /* 5.22.0 -> */ +#else +#define WARNEMUCAT WARN_MISC +#endif +#define WARNEMU(opname) Perl_ck_warner(aTHX_ packWARN(WARNEMUCAT), "Invalid \\0 character in pathname for %s",opname) +#else +#define WARNEMU(opname) Perl_warn(aTHX_ "Invalid \\0 character in pathname for %s",opname) +#endif +#define IS_SAFE_PATHNAME(pv, len, opname) (((len)>1)&&memchr((pv), 0, (len)-1)?(SETERRNO(ENOENT, LIB_INVARG),WARNEMU(opname),FALSE):(TRUE)) +#endif + MODULE = Time::HiRes PACKAGE = Time::HiRes PROTOTYPES: ENABLE @@ -941,7 +975,7 @@ BOOT: # endif #endif #if defined(PERL_DARWIN) -# ifdef USE_ITHREADS +# if defined(USE_ITHREADS) && defined(PERL_DARWIN_MUTEX) MUTEX_INIT(&darwin_time_mutex); # endif #endif @@ -1317,6 +1351,82 @@ getitimer(which) #endif /* #if defined(HAS_GETITIMER) && defined(HAS_SETITIMER) */ +#if defined(TIME_HIRES_UTIME) + +I32 +utime(accessed, modified, ...) +PROTOTYPE: $$@ + PREINIT: + SV* accessed; + SV* modified; + SV* file; + + struct timespec utbuf[2]; + struct timespec *utbufp = utbuf; + int tot; + + CODE: + accessed = ST(0); + modified = ST(1); + items -= 2; + tot = 0; + + if ( accessed == &PL_sv_undef && modified == &PL_sv_undef ) + utbufp = NULL; + else { + if (SvNV(accessed) < 0.0 || SvNV(modified) < 0.0) + croak("Time::HiRes::utime(%"NVgf", %"NVgf"): negative time not invented yet", SvNV(accessed), SvNV(modified)); + Zero(&utbuf, sizeof utbuf, char); + utbuf[0].tv_sec = (Time_t)SvNV(accessed); /* time accessed */ + utbuf[0].tv_nsec = (long)( ( SvNV(accessed) - utbuf[0].tv_sec ) * 1e9 ); + utbuf[1].tv_sec = (Time_t)SvNV(modified); /* time modified */ + utbuf[1].tv_nsec = (long)( ( SvNV(modified) - utbuf[1].tv_sec ) * 1e9 ); + } + + while (items > 0) { + file = POPs; items--; + + if (SvROK(file) && GvIO(SvRV(file)) && IoIFP(sv_2io(SvRV(file)))) { + int fd = PerlIO_fileno(IoIFP(sv_2io(file))); + if (fd < 0) + SETERRNO(EBADF,RMS_IFI); + else +#ifdef HAS_FUTIMENS + if (futimens(fd, utbufp) == 0) + tot++; +#else /* HAS_FUTIMES */ + croak("futimens unimplemented in this platform"); +#endif /* HAS_FUTIMES */ + } + else { +#ifdef HAS_UTIMENSAT + STRLEN len; + char * name = SvPV(file, len); + if (IS_SAFE_PATHNAME(name, len, "utime") && + utimensat(AT_FDCWD, name, utbufp, 0) == 0) + tot++; +#else /* HAS_UTIMENSAT */ + croak("utimensat unimplemented in this platform"); +#endif /* HAS_UTIMENSAT */ + } + } /* while items */ + RETVAL = tot; + + OUTPUT: + RETVAL + +#else /* #if defined(TIME_HIRES_UTIME) */ + +I32 +utime(accessed, modified, ...) + CODE: + croak("Time::HiRes::utime(): unimplemented in this platform"); + RETVAL = 0; + OUTPUT: + RETVAL + +#endif /* #if defined(TIME_HIRES_UTIME) */ + #if defined(TIME_HIRES_CLOCK_GETTIME) NV diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/Makefile.PL b/gnu/usr.bin/perl/dist/Time-HiRes/Makefile.PL index 087ab79871c..1c1ce1f4dea 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/Makefile.PL +++ b/gnu/usr.bin/perl/dist/Time-HiRes/Makefile.PL @@ -354,6 +354,41 @@ int main(int argc, char** argv) EOM } +sub has_futimens { + return 1 if + try_compile_and_link(<<EOM); +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include <sys/time.h> +int main(int argc, char** argv) +{ + int ret; + struct timespec ts[2]; + ret = futimens(0, ts); + ret == 0 ? exit(0) : exit(errno ? errno : -1); +} +EOM +} + +sub has_utimensat{ + return 1 if + try_compile_and_link(<<EOM); +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include <sys/time.h> +#include <fcntl.h> +int main(int argc, char** argv) +{ + int ret; + struct timespec ts[2]; + ret = utimensat(AT_FDCWD, 0, ts, 0); + ret == 0 ? exit(0) : exit(errno ? errno : -1); +} +EOM +} + sub DEFINE { my ($def, $val) = @_; my $define = defined $val ? "$def=$val" : $def ; @@ -548,7 +583,7 @@ EOD } elsif ($^O eq 'darwin') { $has_clock_gettime_emulation++; $has_clock_gettime++; - $DEFINE .= ' -DTIME_HIRES_CLOCK_GETTIME'; + $DEFINE .= ' -DTIME_HIRES_CLOCK_GETTIME -DTIME_HIRES_CLOCK_GETTIME_EMULATION'; } if ($has_clock_gettime) { @@ -577,7 +612,7 @@ EOD } elsif ($^O eq 'darwin') { $has_clock_getres_emulation++; $has_clock_getres++; - $DEFINE .= ' -DTIME_HIRES_CLOCK_GETRES'; + $DEFINE .= ' -DTIME_HIRES_CLOCK_GETRES -DTIME_HIRES_CLOCK_GETRES_EMULATION'; } if ($has_clock_getres) { @@ -603,7 +638,7 @@ EOD } elsif ($^O eq 'darwin') { $has_clock_nanosleep++; $has_clock_nanosleep_emulation++; - $DEFINE .= ' -DTIME_HIRES_CLOCK_NANOSLEEP'; + $DEFINE .= ' -DTIME_HIRES_CLOCK_NANOSLEEP -DTIME_HIRES_CLOCK_NANOSLEEP_EMULATION'; } if ($has_clock_nanosleep) { @@ -631,6 +666,36 @@ EOD print "NOT found.\n"; } + print "Looking for futimens()... "; + my $has_futimens; + if (has_futimens()) { + $has_futimens++; + $DEFINE .= ' -DHAS_FUTIMENS'; + } + + if ($has_futimens) { + print "found.\n"; + } else { + print "NOT found.\n"; + } + + print "Looking for utimensat()... "; + my $has_utimensat; + if (has_utimensat()) { + $has_utimensat++; + $DEFINE .= ' -DHAS_UTIMENSAT'; + } + + if ($has_utimensat) { + print "found.\n"; + } else { + print "NOT found.\n"; + } + + if ($has_futimens or $has_utimensat) { + $DEFINE .= ' -DTIME_HIRES_UTIME'; + } + print "Looking for stat() subsecond timestamps...\n"; print "Trying struct stat st_atimespec.tv_nsec..."; @@ -644,7 +709,7 @@ int main(int argc, char** argv) { } EOM $has_stat_st_xtimespec++; - DEFINE('TIME_HIRES_STAT', 1); + DEFINE('TIME_HIRES_STAT_ST_XTIMESPEC'); # 1 } if ($has_stat_st_xtimespec) { @@ -664,7 +729,7 @@ int main(int argc, char** argv) { } EOM $has_stat_st_xtimensec++; - DEFINE('TIME_HIRES_STAT', 2); + DEFINE('TIME_HIRES_STAT_ST_XTIMENSEC'); # 2 } if ($has_stat_st_xtimensec) { @@ -684,7 +749,7 @@ int main(int argc, char** argv) { } EOM $has_stat_st_xtime_n++; - DEFINE('TIME_HIRES_STAT', 3); + DEFINE('TIME_HIRES_STAT_ST_XTIME_N'); # 3 } if ($has_stat_st_xtime_n) { @@ -704,7 +769,7 @@ int main(int argc, char** argv) { } EOM $has_stat_st_xtim++; - DEFINE('TIME_HIRES_STAT', 4); + DEFINE('TIME_HIRES_STAT_XTIM'); # 4 } if ($has_stat_st_xtim) { @@ -724,7 +789,7 @@ int main(int argc, char** argv) { } EOM $has_stat_st_uxtime++; - DEFINE('TIME_HIRES_STAT', 5); + DEFINE('TIME_HIRES_STAT_ST_UXTIME'); # 5 } if ($has_stat_st_uxtime) { @@ -733,6 +798,19 @@ EOM print "NOT found.\n"; } + # See HiRes.xs hrstatns() + if ($has_stat_st_xtimespec) { + DEFINE('TIME_HIRES_STAT', 1); + } elsif ($has_stat_st_xtimensec) { + DEFINE('TIME_HIRES_STAT', 2); + } elsif ($has_stat_st_xtime_n) { + DEFINE('TIME_HIRES_STAT', 3); + } elsif ($has_stat_st_xtim) { + DEFINE('TIME_HIRES_STAT', 4); + } elsif ($has_stat_st_uxtime) { + DEFINE('TIME_HIRES_STAT', 5); + } + if ($DEFINE =~ /-DTIME_HIRES_STAT=\d+/) { print "You seem to have stat() subsecond timestamps.\n"; print "(Your struct stat has them, but the filesystems must help.)\n"; @@ -791,7 +869,7 @@ sub doMakefile { 'DynaLoader' => 0, 'Exporter' => 0, 'ExtUtils::MakeMaker' => 0, - 'Test::More' => "0.82", + 'Test::More' => 0, 'strict' => 0, }, 'dist' => { @@ -869,7 +947,8 @@ sub doConstants { ); foreach (qw (d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer d_nanosleep d_clock_gettime d_clock_getres - d_clock d_clock_nanosleep d_hires_stat)) { + d_clock d_clock_nanosleep d_hires_stat + d_futimens d_utimensat d_hires_utime)) { my $macro = $_; if ($macro =~ /^(d_nanosleep|d_clock)$/) { $macro =~ s/^d_(.+)/TIME_HIRES_\U$1/; @@ -879,6 +958,13 @@ sub doConstants { push @names, {name => $_, macro => "TIME_HIRES_STAT", value => $d_hires_stat, default => ["IV", "0"]}; next; + } elsif ($macro =~ /^(d_hires_utime)$/) { + my $d_hires_utime = + ($DEFINE =~ /-DHAS_FUTIMENS/ || + $DEFINE =~ /-DHAS_UTIMENSAT/) ? 1 : 0; + push @names, {name => $_, macro => "TIME_HIRES_UTIME", value => $d_hires_utime, + default => ["IV", "0"]}; + next; } elsif ($macro =~ /^(d_clock_gettime|d_clock_getres|d_clock_nanosleep)$/) { $macro =~ s/^d_(.+)/TIME_HIRES_\U$1/; my $val = ($DEFINE =~ /-D$macro\b/) ? 1 : 0; diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/fallback/const-c.inc b/gnu/usr.bin/perl/dist/Time-HiRes/fallback/const-c.inc index a8626172af5..524db169a9f 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/fallback/const-c.inc +++ b/gnu/usr.bin/perl/dist/Time-HiRes/fallback/const-c.inc @@ -19,6 +19,7 @@ typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ #ifndef pTHX_ #define pTHX_ /* 5.6 or later define this for threading support. */ #endif + static int constant_11 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given @@ -87,6 +88,51 @@ constant_11 (pTHX_ const char *name, IV *iv_return) { } static int +constant_13 (pTHX_ const char *name, IV *iv_return) { + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. + CLOCK_HIGHRES TIMER_ABSTIME d_hires_utime */ + /* Offset 1 gives the best switch position. */ + switch (name[1]) { + case 'I': + if (memEQ(name, "TIMER_ABSTIME", 13)) { + /* ^ */ +#ifdef TIMER_ABSTIME + *iv_return = TIMER_ABSTIME; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'L': + if (memEQ(name, "CLOCK_HIGHRES", 13)) { + /* ^ */ +#ifdef CLOCK_HIGHRES + *iv_return = CLOCK_HIGHRES; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case '_': + if (memEQ(name, "d_hires_utime", 13)) { + /* ^ */ +#ifdef TIME_HIRES_UTIME + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + +static int constant_14 (pTHX_ const char *name, IV *iv_return) { /* When generated this function returned values for the list of names given here. However, subsequent manual editing may have added or removed some. @@ -250,16 +296,17 @@ my @names = (qw(CLOCKS_PER_SEC CLOCK_HIGHRES CLOCK_MONOTONIC {name=>"d_getitimer", type=>"IV", macro=>"HAS_GETITIMER", value=>"1", default=>["IV", "0"]}, {name=>"d_gettimeofday", type=>"IV", macro=>"HAS_GETTIMEOFDAY", value=>"1", default=>["IV", "0"]}, {name=>"d_hires_stat", type=>"IV", macro=>"TIME_HIRES_STAT", value=>"1", default=>["IV", "0"]}, + {name=>"d_hires_utime", type=>"IV", macro=>"TIME_HIRES_UTIME", value=>"1", default=>["IV", "0"]}, {name=>"d_nanosleep", type=>"IV", macro=>"TIME_HIRES_NANOSLEEP", value=>"1", default=>["IV", "0"]}, {name=>"d_setitimer", type=>"IV", macro=>"HAS_SETITIMER", value=>"1", default=>["IV", "0"]}, {name=>"d_ualarm", type=>"IV", macro=>"HAS_UALARM", value=>"1", default=>["IV", "0"]}, {name=>"d_usleep", type=>"IV", macro=>"HAS_USLEEP", value=>"1", default=>["IV", "0"]}); -print constant_types(); # macro defs +print constant_types(), "\n"; # macro defs foreach (C_constant ("Time::HiRes", 'constant', 'IV', $types, undef, 3, @names) ) { print $_, "\n"; # C constant subs } -print "#### XS Section:\n"; +print "\n#### XS Section:\n"; print XS_constant ("Time::HiRes", $types); __END__ */ @@ -322,33 +369,7 @@ __END__ } break; case 13: - /* Names all of length 13. */ - /* CLOCK_HIGHRES TIMER_ABSTIME */ - /* Offset 2 gives the best switch position. */ - switch (name[2]) { - case 'M': - if (memEQ(name, "TIMER_ABSTIME", 13)) { - /* ^ */ -#ifdef TIMER_ABSTIME - *iv_return = TIMER_ABSTIME; - return PERL_constant_ISIV; -#else - return PERL_constant_NOTDEF; -#endif - } - break; - case 'O': - if (memEQ(name, "CLOCK_HIGHRES", 13)) { - /* ^ */ -#ifdef CLOCK_HIGHRES - *iv_return = CLOCK_HIGHRES; - return PERL_constant_ISIV; -#else - return PERL_constant_NOTDEF; -#endif - } - break; - } + return constant_13 (aTHX_ name, iv_return); break; case 14: return constant_14 (aTHX_ name, iv_return); diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/Watchdog.pm b/gnu/usr.bin/perl/dist/Time-HiRes/t/Watchdog.pm index 83e854396fd..44ec8081dea 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/Watchdog.pm +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/Watchdog.pm @@ -10,44 +10,44 @@ my $watchdog_pid; my $TheEnd; if ($Config{d_fork}) { - note "I am the main process $$, starting the watchdog process..."; + print("# I am the main process $$, starting the watchdog process...\n"); $watchdog_pid = fork(); if (defined $watchdog_pid) { if ($watchdog_pid == 0) { # We are the kid, set up the watchdog. my $ppid = getppid(); - note "I am the watchdog process $$, sleeping for $waitfor seconds..."; + print("# I am the watchdog process $$, sleeping for $waitfor seconds...\n"); sleep($waitfor - 2); # Workaround for perlbug #49073 sleep(2); # Wait for parent to exit if (kill(0, $ppid)) { # Check if parent still exists warn "\n$0: overall time allowed for tests (${waitfor}s) exceeded!\n"; - note "Terminating main process $ppid..."; + print("Terminating main process $ppid...\n"); kill('KILL', $ppid); - note "This is the watchdog process $$, over and out."; + print("# This is the watchdog process $$, over and out.\n"); } exit(0); } else { - note "The watchdog process $watchdog_pid launched, continuing testing..."; + print("# The watchdog process $watchdog_pid launched, continuing testing...\n"); $TheEnd = time() + $waitfor; } } else { warn "$0: fork failed: $!\n"; } } else { - note "No watchdog process (need fork)"; + print("# No watchdog process (need fork)\n"); } END { if ($watchdog_pid) { # Only in the main process. my $left = $TheEnd - time(); - note sprintf "I am the main process $$, terminating the watchdog process $watchdog_pid before it terminates me in %d seconds (testing took %d seconds).", $left, $waitfor - $left; + printf("# I am the main process $$, terminating the watchdog process $watchdog_pid before it terminates me in %d seconds (testing took %d seconds).\n", $left, $waitfor - $left); if (kill(0, $watchdog_pid)) { local $? = 0; my $kill = kill('KILL', $watchdog_pid); # We are done, the watchdog can go. wait(); - note sprintf "kill KILL $watchdog_pid = %d", $kill; + printf("# kill KILL $watchdog_pid = %d\n", $kill); } unlink("ktrace.out"); # Used in BSD system call tracing. - note "All done."; + print("# All done.\n"); } } diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/alarm.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/alarm.t index 841694f67c2..f600f99256c 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/alarm.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/alarm.t @@ -1,6 +1,6 @@ use strict; -use Test::More 0.82 tests => 10; +use Test::More tests => 10; use t::Watchdog; BEGIN { require_ok "Time::HiRes"; } @@ -29,12 +29,14 @@ SKIP: { my ($r, $i, $not, $ok); + $not = ""; + $r = [Time::HiRes::gettimeofday()]; $i = 5; my $oldaction; if ($use_sigaction) { $oldaction = new POSIX::SigAction; - note sprintf "sigaction tick, ALRM = %d", &POSIX::SIGALRM; + printf("# sigaction tick, ALRM = %d\n", &POSIX::SIGALRM); # Perl's deferred signals may be too wimpy to break through # a restartable select(), so use POSIX::sigaction if available. @@ -44,7 +46,7 @@ SKIP: { $oldaction) or die "Error setting SIGALRM handler with sigaction: $!\n"; } else { - note "SIG tick"; + print("# SIG tick\n"); $SIG{ALRM} = "tick"; } @@ -56,8 +58,8 @@ SKIP: { Time::HiRes::alarm(0.3); select (undef, undef, undef, 3); my $ival = Time::HiRes::tv_interval ($r); - note "Select returned! $i $ival"; - note abs($ival/3 - 1); + print("# Select returned! $i $ival\n"); + printf("# %s\n", abs($ival/3 - 1)); # Whether select() gets restarted after signals is # implementation dependent. If it is restarted, we # will get about 3.3 seconds: 3 from the select, 0.3 @@ -86,7 +88,7 @@ SKIP: { sub tick { $i--; my $ival = Time::HiRes::tv_interval ($r); - note "Tick! $i $ival"; + print("# Tick! $i $ival\n"); my $exp = 0.3 * (5 - $i); if ($exp == 0) { $not = "tick: divisor became zero"; @@ -106,8 +108,8 @@ SKIP: { Time::HiRes::alarm(0); # can't cancel usig %SIG } + print("# $not\n"); ok !$not; - note $not || $ok; } SKIP: { @@ -126,7 +128,7 @@ SKIP: { # http://groups.google.com/group/perl.perl5.porters/browse_thread/thread/adaffaaf939b042e/20dafc298df737f0%2320dafc298df737f0?sa=X&oi=groupsr&start=0&num=3 # Perl changes [18765] and [18770], perl bug [perl #20920] - note "Finding delay loop..."; + print("# Finding delay loop...\n"); my $T = 0.01; my $DelayN = 1024; @@ -137,7 +139,7 @@ SKIP: { for ($i = 0; $i < $DelayN; $i++) { } my $t1 = Time::HiRes::time(); my $dt = $t1 - $t0; - note "N = $DelayN, t1 = $t1, t0 = $t0, dt = $dt"; + print("# N = $DelayN, t1 = $t1, t0 = $t0, dt = $dt\n"); last N if $dt > $T; $DelayN *= 2; } while (1); @@ -169,7 +171,7 @@ SKIP: { $SIG{ALRM} = sub { $a++; - note "Alarm $a - ", Time::HiRes::time(); + printf("# Alarm $a - %s\n", Time::HiRes::time()); Time::HiRes::alarm(0) if $a >= $A; # Disarm the alarm. $Delay->(2); # Try burning CPU at least for 2T seconds. }; @@ -204,18 +206,18 @@ SKIP: { my $alrm = 0; $SIG{ALRM} = sub { $alrm++ }; my $got = Time::HiRes::alarm(2.7); - ok $got == 0 or note $got; + ok $got == 0 or print("# $got\n"); my $t0 = Time::HiRes::time(); 1 while Time::HiRes::time() - $t0 <= 1; $got = Time::HiRes::alarm(0); - ok $got > 0 && $got < 1.8 or note $got; + ok $got > 0 && $got < 1.8 or print("# $got\n"); - ok $alrm == 0 or note $alrm; + ok $alrm == 0 or print("# $alrm\n"); $got = Time::HiRes::alarm(0); - ok $got == 0 or note $got; + ok $got == 0 or print("# $got\n"); } } diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/clock.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/clock.t index 6d11dd2ca0a..346ca57fbf5 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/clock.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/clock.t @@ -1,6 +1,6 @@ use strict; -use Test::More 0.82 tests => 5; +use Test::More tests => 5; use t::Watchdog; BEGIN { require_ok "Time::HiRes"; } @@ -13,10 +13,10 @@ sub has_symbol { return $@ eq ''; } -note sprintf "have_clock_gettime = %d", &Time::HiRes::d_clock_gettime; -note sprintf "have_clock_getres = %d", &Time::HiRes::d_clock_getres; -note sprintf "have_clock_nanosleep = %d", &Time::HiRes::d_clock_nanosleep; -note sprintf "have_clock = %d", &Time::HiRes::d_clock; +printf("# have_clock_gettime = %d\n", &Time::HiRes::d_clock_gettime); +printf("# have_clock_getres = %d\n", &Time::HiRes::d_clock_getres); +printf("# have_clock_nanosleep = %d\n", &Time::HiRes::d_clock_nanosleep); +printf("# have_clock = %d\n", &Time::HiRes::d_clock); # Ideally, we'd like to test that the timers are rather precise. # However, if the system is busy, there are no guarantees on how @@ -36,25 +36,25 @@ SKIP: { my $ok = 0; TRY: { for my $try (1..3) { - note "CLOCK_REALTIME: try = $try"; + print("# CLOCK_REALTIME: try = $try\n"); my $t0 = Time::HiRes::clock_gettime(&CLOCK_REALTIME); my $T = 1.5; Time::HiRes::sleep($T); my $t1 = Time::HiRes::clock_gettime(&CLOCK_REALTIME); if ($t0 > 0 && $t1 > $t0) { - note "t1 = $t1, t0 = $t0"; + print("# t1 = $t1, t0 = $t0\n"); my $dt = $t1 - $t0; my $rt = abs(1 - $dt / $T); - note "dt = $dt, rt = $rt"; + print("# dt = $dt, rt = $rt\n"); if ($rt <= 2 * $limit) { $ok = 1; last TRY; } } else { - note "Error: t0 = $t0, t1 = $t1"; + print("# Error: t0 = $t0, t1 = $t1\n"); } my $r = rand() + rand(); - note sprintf "Sleeping for %.6f seconds...\n", $r; + printf("# Sleeping for %.6f seconds...\n", $r); Time::HiRes::sleep($r); } } @@ -64,7 +64,7 @@ SKIP: { SKIP: { skip "no clock_getres", 1 unless &Time::HiRes::d_clock_getres; my $tr = Time::HiRes::clock_getres(); - ok $tr > 0 or note "tr = $tr"; + ok $tr > 0 or print("# tr = $tr\n"); } SKIP: { @@ -73,17 +73,17 @@ SKIP: { my $s = 1.5e9; my $t = Time::HiRes::clock_nanosleep(&CLOCK_REALTIME, $s); my $r = abs(1 - $t / $s); - ok $r < 2 * $limit or note "t = $t, r = $r"; + ok $r < 2 * $limit or print("# t = $t, r = $r\n"); } SKIP: { skip "no clock", 1 unless &Time::HiRes::d_clock; my @clock = Time::HiRes::clock(); - note "clock = @clock"; + print("# clock = @clock\n"); for my $i (1..3) { for (my $j = 0; $j < 1e6; $j++) { } push @clock, Time::HiRes::clock(); - note "clock = @clock"; + print("# clock = @clock\n"); } ok $clock[0] >= 0 && $clock[1] > $clock[0] && diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/gettimeofday.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/gettimeofday.t index 8f7c5f3039a..69defe8672e 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/gettimeofday.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/gettimeofday.t @@ -8,26 +8,26 @@ BEGIN { } } -use Test::More 0.82 tests => 6; +use Test::More tests => 6; use t::Watchdog; my @one = Time::HiRes::gettimeofday(); -note 'gettimeofday returned ', 0+@one, ' args'; +printf("# gettimeofday returned %d args\n", 0+@one); ok @one == 2; -ok $one[0] > 850_000_000 or note "@one too small"; +ok $one[0] > 850_000_000 or print("# @one too small\n"); sleep 1; my @two = Time::HiRes::gettimeofday(); ok $two[0] > $one[0] || ($two[0] == $one[0] && $two[1] > $one[1]) - or note "@two is not greater than @one"; + or print("# @two is not greater than @one\n"); my $f = Time::HiRes::time(); -ok $f > 850_000_000 or note "$f too small"; -ok $f - $two[0] < 2 or note "$f - $two[0] >= 2"; +ok $f > 850_000_000 or print("# $f too small\n"); +ok $f - $two[0] < 2 or print("# $f - $two[0] >= 2\n"); my $r = [Time::HiRes::gettimeofday()]; my $g = Time::HiRes::tv_interval $r; -ok $g < 2 or note $g; +ok $g < 2 or print("# $g\n"); 1; diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/itimer.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/itimer.t index 9eb2b93f6f0..31cdd674ae7 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/itimer.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/itimer.t @@ -25,7 +25,7 @@ BEGIN { } } -use Test::More 0.82 tests => 2; +use Test::More tests => 2; use t::Watchdog; my $limit = 0.25; # 25% is acceptable slosh for testing timers @@ -35,11 +35,11 @@ my $r = [Time::HiRes::gettimeofday()]; $SIG{VTALRM} = sub { $i ? $i-- : Time::HiRes::setitimer(&Time::HiRes::ITIMER_VIRTUAL, 0); - note "Tick! $i ", Time::HiRes::tv_interval($r); + printf("# Tick! $i %s\n", Time::HiRes::tv_interval($r)); }; -note "setitimer: ", join(" ", - Time::HiRes::setitimer(&Time::HiRes::ITIMER_VIRTUAL, 0.5, 0.4)); +printf("# setitimer: %s\n", join(" ", + Time::HiRes::setitimer(&Time::HiRes::ITIMER_VIRTUAL, 0.5, 0.4))); # Assume interval timer granularity of $limit * 0.5 seconds. Too bold? my $virt = Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL); @@ -47,19 +47,19 @@ ok(defined $virt && abs($virt / 0.5) - 1 < $limit, "ITIMER_VIRTUAL defined with sufficient granularity") or diag "virt=" . (defined $virt ? $virt : 'undef'); -note "getitimer: ", join(" ", - Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL)); +printf("# getitimer: %s\n", join(" ", + Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL))); while (Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL)) { my $j; for (1..1000) { $j++ } # Can't be unbreakable, must test getitimer(). } -note "getitimer: ", join(" ", - Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL)); +printf("# getitimer: %s\n", join(" ", + Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL))); $virt = Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL); -note "at end, i=$i"; +print("# at end, i=$i\n"); is($virt, 0, "time left should be zero"); $SIG{VTALRM} = 'DEFAULT'; diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/nanosleep.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/nanosleep.t index aef9db6163c..c17a7e4790e 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/nanosleep.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/nanosleep.t @@ -8,7 +8,7 @@ BEGIN { } } -use Test::More 0.82 tests => 3; +use Test::More tests => 3; use t::Watchdog; eval { Time::HiRes::nanosleep(-5) }; @@ -21,7 +21,7 @@ my $two = CORE::time; Time::HiRes::nanosleep(10_000_000); my $three = CORE::time; ok $one == $two || $two == $three - or note "slept too long, $one $two $three"; + or print("# slept too long, $one $two $three\n"); SKIP: { skip "no gettimeofday", 1 unless &Time::HiRes::d_gettimeofday; @@ -29,7 +29,7 @@ SKIP: { Time::HiRes::nanosleep(500_000_000); my $f2 = Time::HiRes::time(); my $d = $f2 - $f; - ok $d > 0.4 && $d < 0.9 or note "slept $d secs $f to $f2"; + ok $d > 0.4 && $d < 0.9 or print("# slept $d secs $f to $f2\n"); } 1; diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/sleep.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/sleep.t index e7cc6271a89..c4d802be402 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/sleep.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/sleep.t @@ -1,6 +1,6 @@ use strict; -use Test::More 0.82 tests => 4; +use Test::More tests => 4; use t::Watchdog; BEGIN { require_ok "Time::HiRes"; } @@ -26,12 +26,12 @@ like $@, qr/::sleep\(-1\): negative time not invented yet/, SKIP: { skip "no subsecond alarm", 2 unless $can_subsecond_alarm; my $f = Time::HiRes::time; - note "time...$f"; + print("# time...$f\n"); ok 1; my $r = [Time::HiRes::gettimeofday()]; Time::HiRes::sleep (0.5); - note "sleep...", Time::HiRes::tv_interval($r); + printf("# sleep...%s\n", Time::HiRes::tv_interval($r)); ok 1; } diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/stat.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/stat.t index 68a6fb6bbdc..e7552b5e256 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/stat.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/stat.t @@ -13,7 +13,7 @@ BEGIN { } } -use Test::More 0.82 tests => 43; +use Test::More tests => 43; use t::Watchdog; my @atime; @@ -42,8 +42,8 @@ for (1..5) { is_deeply $lstat, $stat; } 1 while unlink $$; -note "mtime = @mtime"; -note "atime = @atime"; +print("# mtime = @mtime\n"); +print("# atime = @atime\n"); my $ai = 0; my $mi = 0; my $ss = 0; @@ -63,7 +63,7 @@ for (my $i = 1; $i < @mtime; $i++) { $ss++; } } -note "ai = $ai, mi = $mi, ss = $ss"; +print("# ai = $ai, mi = $mi, ss = $ss\n"); # Need at least 75% of monotonical increase and # 20% of subsecond results. Yes, this is guessing. SKIP: { diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/time.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/time.t index feec4799d90..6f219f9e0c4 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/time.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/time.t @@ -1,6 +1,6 @@ use strict; -use Test::More 0.82 tests => 2; +use Test::More tests => 2; use t::Watchdog; BEGIN { require_ok "Time::HiRes"; } @@ -16,8 +16,8 @@ SKIP: { # (CORE::time() may be rounding down, up, or closest), # but allow 10% of slop. ok abs($s) / $n <= 1.10 - or note "Time::HiRes::time() not close to CORE::time()"; - note "s = $s, n = $n, s/n = ", abs($s)/$n; + or print("# Time::HiRes::time() not close to CORE::time()\n"); + printf("# s = $s, n = $n, s/n = %s\n", abs($s)/$n); } 1; diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/tv_interval.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/tv_interval.t index bffcf39ec10..8ac876daf3a 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/tv_interval.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/tv_interval.t @@ -1,10 +1,10 @@ use strict; -use Test::More 0.82 tests => 2; +use Test::More tests => 2; BEGIN { require_ok "Time::HiRes"; } my $f = Time::HiRes::tv_interval [5, 100_000], [10, 500_000]; -ok abs($f - 5.4) < 0.001 or note $f; +ok abs($f - 5.4) < 0.001 or print("# $f\n"); 1; diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/ualarm.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/ualarm.t index 12ef4b52cc5..b50a175f449 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/ualarm.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/ualarm.t @@ -8,7 +8,7 @@ BEGIN { } } -use Test::More 0.82 tests => 12; +use Test::More tests => 12; use t::Watchdog; use Config; @@ -24,13 +24,13 @@ SKIP: { $tick = 0; Time::HiRes::ualarm(10_000); while ($tick == 0) { } my $three = CORE::time; ok $one == $two || $two == $three - or note "slept too long, $one $two $three"; - note "tick = $tick, one = $one, two = $two, three = $three"; + or print("# slept too long, $one $two $three\n"); + print("# tick = $tick, one = $one, two = $two, three = $three\n"); $tick = 0; Time::HiRes::ualarm(10_000, 10_000); while ($tick < 3) { } ok 1; Time::HiRes::ualarm(0); - note "tick = $tick, one = $one, two = $two, three = $three"; + print("# tick = $tick, one = $one, two = $two, three = $three\n"); } eval { Time::HiRes::ualarm(-4) }; @@ -59,24 +59,24 @@ for my $n (100_000, 1_100_000, 2_200_000, 4_300_000) { my $alarmed = 0; local $SIG{ ALRM } = sub { $alarmed++ }; my $t0 = Time::HiRes::time(); - note "t0 = $t0"; - note "ualarm($n)"; + print("# t0 = $t0\n"); + print("# ualarm($n)\n"); Time::HiRes::ualarm($n); 1 while $alarmed == 0; my $t1 = Time::HiRes::time(); - note "t1 = $t1"; + print("# t1 = $t1\n"); my $dt = $t1 - $t0; - note "dt = $dt"; + print("# dt = $dt\n"); my $r = $dt / ($n/1e6); - note "r = $r"; + print("# r = $r\n"); $ok = ($n < 1_000_000 || # Too much noise. ($r >= 0.8 && $r <= 1.6)); last if $ok; my $nap = bellish(3, 15); - note sprintf "Retrying in %.1f seconds...\n", $nap; + printf("# Retrying in %.1f seconds...\n", $nap); Time::HiRes::sleep($nap); } - ok $ok or note "ualarm($n) close enough"; + ok $ok or print("# ualarm($n) close enough\n"); } { @@ -93,12 +93,12 @@ for my $n (100_000, 1_100_000, 2_200_000, 4_300_000) { } while $t1 - $t0 <= 0.3; my $got1 = Time::HiRes::ualarm(0); - note "t0 = $t0"; - note "got0 = $got0"; - note "t1 = $t1"; - note "t1 - t0 = ", ($t1 - $t0); - note "got1 = $got1"; - ok $got0 == 0 or note $got0; + print("# t0 = $t0\n"); + print("# got0 = $got0\n"); + print("# t1 = $t1\n"); + printf("# t1 - t0 = %s\n", ($t1 - $t0)); + print("# got1 = $got1\n"); + ok $got0 == 0 or print("# $got0\n"); SKIP: { skip "alarm interval exceeded", 2 if $t1 - $t0 >= 0.5; ok $got1 > 0; @@ -106,7 +106,7 @@ for my $n (100_000, 1_100_000, 2_200_000, 4_300_000) { } ok $got1 < 300_000; my $got2 = Time::HiRes::ualarm(0); - ok $got2 == 0 or note $got2; + ok $got2 == 0 or print("# $got2\n"); } 1; diff --git a/gnu/usr.bin/perl/dist/Time-HiRes/t/usleep.t b/gnu/usr.bin/perl/dist/Time-HiRes/t/usleep.t index 0d6bacfac34..bdf372bd163 100644 --- a/gnu/usr.bin/perl/dist/Time-HiRes/t/usleep.t +++ b/gnu/usr.bin/perl/dist/Time-HiRes/t/usleep.t @@ -8,7 +8,7 @@ BEGIN { } } -use Test::More 0.82 tests => 6; +use Test::More tests => 6; use t::Watchdog; eval { Time::HiRes::usleep(-2) }; @@ -23,7 +23,7 @@ my $two = CORE::time; Time::HiRes::usleep(10_000); my $three = CORE::time; ok $one == $two || $two == $three -or note "slept too long, $one $two $three"; +or print("# slept too long, $one $two $three\n"); SKIP: { skip "no gettimeofday", 1 unless &Time::HiRes::d_gettimeofday; @@ -31,7 +31,7 @@ SKIP: { Time::HiRes::usleep(500_000); my $f2 = Time::HiRes::time(); my $d = $f2 - $f; - ok $d > 0.4 && $d < 0.9 or note "slept $d secs $f to $f2"; + ok $d > 0.4 && $d < 0.9 or print("# slept $d secs $f to $f2\n"); } SKIP: { @@ -39,7 +39,7 @@ SKIP: { my $r = [ Time::HiRes::gettimeofday() ]; Time::HiRes::sleep( 0.5 ); my $f = Time::HiRes::tv_interval $r; - ok $f > 0.4 && $f < 0.9 or note "slept $f instead of 0.5 secs."; + ok $f > 0.4 && $f < 0.9 or print("# slept $f instead of 0.5 secs.\n"); } SKIP: { @@ -59,7 +59,7 @@ SKIP: { SKIP: { skip $msg, 1 unless $td < $sleep * (1 + $limit); - ok $a < $limit or note $msg; + ok $a < $limit or print("# $msg\n"); } $t0 = Time::HiRes::gettimeofday(); @@ -71,7 +71,7 @@ SKIP: { SKIP: { skip $msg, 1 unless $td < $sleep * (1 + $limit); - ok $a < $limit or note $msg; + ok $a < $limit or print("# $msg\n"); } } diff --git a/gnu/usr.bin/perl/dist/threads-shared/t/stress.t b/gnu/usr.bin/perl/dist/threads-shared/t/stress.t index 1dd95e39595..e3c1441288e 100755 --- a/gnu/usr.bin/perl/dist/threads-shared/t/stress.t +++ b/gnu/usr.bin/perl/dist/threads-shared/t/stress.t @@ -83,7 +83,7 @@ use threads::shared; print "# Looping for $busycount iterations should take about 0.025s\n"; } - my $TIMEOUT = 60; + my $TIMEOUT = 600; my $mutex = 1; share($mutex); diff --git a/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL b/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL index 864af3ed8e2..81bd54665a7 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL +++ b/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL @@ -65,8 +65,8 @@ sub MY::static { return " $object : \$(FIRST_MAKEFILE) \$(OBJECT) - \$(RM_RF) $object - \$(CP) \$(OBJECT) $object + #\$(RM_RF) $object + #\$(CP) \$(OBJECT) $object static :: $object "; diff --git a/gnu/usr.bin/perl/ext/NDBM_File/Makefile.PL b/gnu/usr.bin/perl/ext/NDBM_File/Makefile.PL index a8adbf01218..a48c039fa88 100644 --- a/gnu/usr.bin/perl/ext/NDBM_File/Makefile.PL +++ b/gnu/usr.bin/perl/ext/NDBM_File/Makefile.PL @@ -1,7 +1,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'NDBM_File', - LIBS => ["-L/usr/local/lib -lndbm", "-ldbm -lucb"], + #LIBS => ["-L/usr/local/lib -lndbm", "-ldbm -lucb"], XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'NDBM_File.pm', INC => ($^O eq "MacOS" ? "-i ::::db:include" : "") diff --git a/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t b/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t index d19341c2461..b96812f3470 100644 --- a/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t +++ b/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t @@ -202,7 +202,7 @@ SKIP: { $skip{pid}{$^O} = $skip{uid}{$^O} = "not set for kill()" if (($^O.$Config{osvers}) =~ /^darwin[0-8]\./ || - ($^O.$Config{osvers}) =~ /^openbsd[0-5]\./); + ($^O.$Config{osvers}) =~ /^openbsd[0-6]\./); my $tests = keys %{{ %siginfo, %opt_val }}; eval 'use POSIX qw(SA_SIGINFO); SA_SIGINFO'; skip("no SA_SIGINFO", $tests) if $@; diff --git a/gnu/usr.bin/perl/hints/openbsd.sh b/gnu/usr.bin/perl/hints/openbsd.sh index 6c366ec2d08..c36b9acadae 100644 --- a/gnu/usr.bin/perl/hints/openbsd.sh +++ b/gnu/usr.bin/perl/hints/openbsd.sh @@ -84,6 +84,8 @@ esac # around for old NetBSD binaries. libswanted=`echo $libswanted | sed 's/ crypt / /'` +libswanted=`echo $libswanted | sed 's/ util / /'` + # Configure can't figure this out non-interactively d_suidsafe=$define @@ -101,6 +103,13 @@ m88k-3.4) ;; esac +# Special per-arch specific ccflags +case "${ARCH}-${osvers}" in + vax-*) + ccflags="-DUSE_PERL_ATOF=0 $ccflags" + ;; +esac + # This script UU/usethreads.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use threads. cat > UU/usethreads.cbu <<'EOCBU' @@ -122,6 +131,9 @@ $define|true|[yY]*) # Broken up to OpenBSD 3.6, fixed in OpenBSD 3.7 d_getservbyname_r=$undef ;; esac + ;; +*) + libswanted=`echo $libswanted | sed 's/ pthread / /'` esac EOCBU @@ -140,12 +152,12 @@ case "$openbsd_distribution" in siteprefix='/usr/local' siteprefixexp='/usr/local' # Ports installs non-std libs in /usr/local/lib so look there too - locincpth='/usr/local/include' - loclibpth='/usr/local/lib' + locincpth='' + loclibpth='' # Link perl with shared libperl - if [ "$usedl" = "$define" -a -r shlib_version ]; then + if [ "$usedl" = "$define" -a -r $src/shlib_version ]; then useshrplib=true - libperl=`. ./shlib_version; echo libperl.so.${major}.${minor}` + libperl=`. $src/shlib_version; echo libperl.so.${major}.${minor}` fi ;; esac diff --git a/gnu/usr.bin/perl/install_lib.pl b/gnu/usr.bin/perl/install_lib.pl index ac17bd81d81..8ca801b00a6 100644 --- a/gnu/usr.bin/perl/install_lib.pl +++ b/gnu/usr.bin/perl/install_lib.pl @@ -6,7 +6,7 @@ use strict; use vars qw($Is_VMS $Is_W32 $Is_OS2 $Is_Cygwin $Is_Darwin $Is_NetWare $Is_AmigaOS %opts $packlist); -use subs qw(unlink link chmod); +use subs qw(unlink link chmod chown); require File::Path; require File::Copy; @@ -99,6 +99,9 @@ sub link { unless -f $to and (chmod(0666, $to), unlink $to) and File::Copy::copy($from, $to) and ++$success; } + if (defined($opts{uid}) || defined($opts{gid})) { + chown($opts{uid}, $opts{gid}, $to) if $success; + } $packlist->{$xto} = { type => 'file' }; } $success; @@ -114,6 +117,16 @@ sub chmod { unless $opts{notify}; } +sub chown { + my($uid,$gid,$name) = @_; + + return if ($^O eq 'dos'); + printf " chown %s:%s %s\n", $uid, $gid, $name if $opts{verbose}; + CORE::chown($uid,$gid,$name) + || warn sprintf("Couldn't chown %s:%s %s: $!\n", $uid, $gid, $name) + unless $opts{notify}; +} + sub samepath { my($p1, $p2) = @_; @@ -145,7 +158,8 @@ sub safe_rename { } sub mkpath { - File::Path::mkpath(shift , $opts{verbose}, 0777) unless $opts{notify}; + File::Path::make_path(shift, {owner=>$opts{uid}, group=>$opts{gid}, + mode=>0777, verbose=>$opts{verbose}}) unless $opts{notify}; } sub unixtoamiga diff --git a/gnu/usr.bin/perl/installperl b/gnu/usr.bin/perl/installperl index f4d850be34c..452dd2efd8b 100644 --- a/gnu/usr.bin/perl/installperl +++ b/gnu/usr.bin/perl/installperl @@ -77,8 +77,8 @@ $opts{destdir} = ''; my $usage = 0; if (!GetOptions(\%opts, 'notify|n', 'strip|s', 'silent|S', 'skip-otherperls|o', 'force|f', 'verbose|V', 'archname|A', - 'netware', 'nopods|p', 'destdir:s', 'help|h|?', - 'versiononly|v' => \$versiononly, '<>' => sub { + 'netware', 'nopods|p', 'destdir:s', 'help|h|?', 'user|u:s', + 'group|g:s', 'versiononly|v' => \$versiononly, '<>' => sub { if ($_[0] eq '+v') { $versiononly = 0; } else { @@ -107,6 +107,8 @@ Usage $0: [switches] -A Also install perl with the architecture's name in the perl binary's name. -p Don't install the pod files. [This will break use diagnostics;] + -g group install files with the specified group + -u user install files with the specified user -netware Install correctly on a Netware server. -destdir Prefix installation directories by this string. -h Display this help message. @@ -114,6 +116,8 @@ EOT exit $usage; } } +$opts{'uid'} = getpwnam($opts{'user'}) if exists($opts{'user'}); +$opts{'gid'} = getgrnam($opts{'group'}) if exists($opts{'group'}); $versiononly = 1 if $Config{versiononly} && !defined $versiononly; my (@scripts, @tolink); @@ -153,7 +157,7 @@ if ((-e "testcompile") && (defined($ENV{'COMPILE'}))) { } # Exclude nonxs extensions that are not architecture dependent -my @nonxs = grep(!/^Errno$/, split(' ', $Config{'nonxs_ext'})); +my @nonxs = grep(!/^(Errno|IO\/Compress)$/, split(' ', $Config{'nonxs_ext'})); my @ext_dirs = qw(cpan dist ext); foreach my $ext_dir (@ext_dirs) { @@ -199,7 +203,7 @@ my $installprivlib = "$opts{destdir}$Config{installprivlib}"; my $installarchlib = "$opts{destdir}$Config{installarchlib}"; my $installsitelib = "$opts{destdir}$Config{installsitelib}"; my $installsitearch = "$opts{destdir}$Config{installsitearch}"; -my $installman1dir = "$opts{destdir}$Config{installman1dir}"; +my $installman1dir = "none"; my $man1ext = $Config{man1ext}; my $libperl = $Config{libperl}; # Shared library and dynamic loading suffixes. @@ -239,8 +243,6 @@ if ($Is_VMS) { # Hang in there until File::Spec hits the big time $installbin || die "No installbin directory in config.sh\n"; -d $installbin || mkpath($installbin); -d $installbin || $opts{notify} || die "$installbin is not a directory\n"; --w $installbin || $opts{notify} || die "$installbin is not writable by you\n" - unless $installbin =~ m#^/afs/# || $opts{notify}; if (!$Is_NetWare) { if (!$Is_VMS) { @@ -253,9 +255,9 @@ else { } } --f 't/rantests' || $Is_W32 - || warn "WARNING: You've never run 'make test' or", - " some tests failed! (Installing anyway.)\n"; +#-f 't/rantests' || $Is_W32 +# || warn "WARNING: You've never run 'make test' or", +# " some tests failed! (Installing anyway.)\n"; } #if (!$Is_NetWare) # This will be used to store the packlist @@ -281,6 +283,10 @@ if (($Is_W32 and ! $Is_NetWare) or $Is_Cygwin) { $packlist->{"$Config{installbin}/$perldll"} = { type => 'file' }; } # if (($Is_W32 and ! $Is_NetWare) or $Is_Cygwin) +# Get the install command and flags from the environment +my @installcmd = $ENV{"INSTALL"} || "install"; +push(@installcmd, $ENV{"INSTALL_COPY"} || "-c"); + # First we install the version-numbered executables. if ($Is_VMS) { @@ -301,10 +307,8 @@ if ($Is_VMS) { } elsif ($^O ne 'dos') { if (!$Is_NetWare) { - safe_unlink("$installbin/$perl_verbase$ver$exe_ext"); - copy("perl$exe_ext", "$installbin/$perl_verbase$ver$exe_ext"); - strip("$installbin/$perl_verbase$ver$exe_ext"); - chmod(0755, "$installbin/$perl_verbase$ver$exe_ext"); + my $ver = ''; # don't install a versioned perl binary + install("perl$exe_ext", "$installbin/$perl_verbase$ver$exe_ext", "0755"); } else { # If installing onto a NetWare server @@ -377,7 +381,9 @@ elsif ($Is_Cygwin) { # On Cygwin symlink it to CORE to make Makefile happy @corefiles = <*.h>; } else { # [als] hard-coded 'libperl' name... not good! - @corefiles = <*.h libperl*.* perl*$Config{lib_ext}>; + #@corefiles = <*.h libperl*.* perl*$Config{lib_ext}>; + @corefiles = <*.h *.inc perl*$Config{lib_ext}>; + push(@corefiles,<libperl*.*>) unless defined($ENV{"NOLIBINSTALL"}); # AIX needs perl.exp installed as well. push(@corefiles,'perl.exp') if $^O eq 'aix'; @@ -405,7 +411,8 @@ if ($Is_W32) { #linking lib isn't made in root but in CORE on Win32 # Install main perl executables # Make links to ordinary names if installbin directory isn't current directory. -if (! $versiononly && ! samepath($installbin, '.') && ($^O ne 'dos') && ! $Is_VMS && ! $Is_NetWare) { +if (0) { # don't install a versioned perl binary +#if (! $versiononly && ! samepath($installbin, '.') && ($^O ne 'dos') && ! $Is_VMS && ! $Is_NetWare) { safe_unlink("$installbin/$perl$exe_ext", "$installbin/suid$perl$exe_ext"); if ($^O eq 'vos') { # VOS doesn't support hard links, so use a symlink. @@ -586,6 +593,9 @@ if (!$versiononly && !$opts{'skip-otherperls'}) { } $packlist->write() unless $opts{notify}; +if (defined($opts{uid}) || defined($opts{gid})) { + chown($opts{uid}, $opts{gid}, $packlist->packlist_file()); +} print " Installation complete\n" if $opts{verbose}; exit 0; @@ -624,6 +634,7 @@ sub safe_unlink { sub copy { my($from,$to) = @_; + my($success) = 0; my $xto = $to; $xto =~ s/^\Q$opts{destdir}\E//; @@ -631,12 +642,32 @@ sub copy { unless $opts{silent}; print " creating new version of $xto\n" if $Is_VMS and -e $to and !$opts{silent}; - unless ($opts{notify} or File::Copy::copy($from, $to)) { + unless ($opts{notify} or File::Copy::copy($from, $to) and ++$success) { # Might have been that F::C::c can't overwrite the target warn "Couldn't copy $from to $to: $!\n" unless -f $to and (chmod(0666, $to), unlink $to) - and File::Copy::copy($from, $to); + and File::Copy::copy($from, $to) and ++$success; } + if (defined($opts{uid}) || defined($opts{gid})) { + chown($opts{uid}, $opts{gid}, $to) if $success; + } + $packlist->{$xto} = { type => 'file' }; +} + +sub install { + my($from,$to,$mode) = @_; + + my $xto = $to; + my $cmd = join(' ', @installcmd); + $cmd .= " -m $mode" if $mode; + $cmd .= " -o $opts{uid}" if defined($opts{uid}); + $cmd .= " -g $opts{gid}" if defined($opts{gid}); + $cmd .= " -s" if $opts{strip}; + $cmd .= " $from $to"; + $xto =~ s/^\Q$opts{destdir}\E// if $opts{destdir}; + print $opts{verbose} ? " install $from $xto\n" : " $xto\n" unless $opts{silent}; + system($cmd); + warn "Couldn't $cmd\n" if $?; $packlist->{$xto} = { type => 'file' }; } @@ -668,6 +699,10 @@ sub installlib { return; } + # If we have different install version, install that instead + return if -e "$_.install"; + $name =~ s/\.install$//; + # ignore patch backups, RCS files, emacs backup & temp files and the # .exists files, .PL files, and test files. return if $name =~ m{\.orig$|\.rej$|~$|^#.+#$|,v$|^\.exists|\.PL$|\.plc$|\.t$|^test\.pl$|^dbm_filter_util\.pl$|^filter-util\.pl$|^uupacktool\.pl$|^\.gitignore$} || diff --git a/gnu/usr.bin/perl/lib/AnyDBM_File.pm b/gnu/usr.bin/perl/lib/AnyDBM_File.pm index 4153af2de2d..3b41a4a100b 100644 --- a/gnu/usr.bin/perl/lib/AnyDBM_File.pm +++ b/gnu/usr.bin/perl/lib/AnyDBM_File.pm @@ -22,8 +22,6 @@ __END__ AnyDBM_File - provide framework for multiple DBMs -NDBM_File, DB_File, GDBM_File, SDBM_File, ODBM_File - various DBM implementations - =head1 SYNOPSIS use AnyDBM_File; diff --git a/gnu/usr.bin/perl/lib/Getopt/Std.pm b/gnu/usr.bin/perl/lib/Getopt/Std.pm index b7f8132b381..b98bd57f077 100644 --- a/gnu/usr.bin/perl/lib/Getopt/Std.pm +++ b/gnu/usr.bin/perl/lib/Getopt/Std.pm @@ -4,7 +4,7 @@ require Exporter; =head1 NAME -getopt, getopts - Process single-character switches with switch clustering +Getopt::Std, getopt, getopts - Process single-character switches with switch clustering =head1 SYNOPSIS diff --git a/gnu/usr.bin/perl/perl.c b/gnu/usr.bin/perl/perl.c index 6197ea08d55..f81f39c3c9c 100644 --- a/gnu/usr.bin/perl/perl.c +++ b/gnu/usr.bin/perl/perl.c @@ -1835,6 +1835,8 @@ S_Internals_V(pTHX_ CV *cv) # endif #endif +#undef PERL_BUILD_DATE + #ifdef PERL_BUILD_DATE PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled at " PERL_BUILD_DATE), diff --git a/gnu/usr.bin/perl/pod/perlmodinstall.pod b/gnu/usr.bin/perl/pod/perlmodinstall.pod index f92620c6d61..9a2634e9ab3 100644 --- a/gnu/usr.bin/perl/pod/perlmodinstall.pod +++ b/gnu/usr.bin/perl/pod/perlmodinstall.pod @@ -79,11 +79,11 @@ You can get gzip from ftp://prep.ai.mit.edu/pub/gnu/ Or, you can combine this step with the next to save disk space: - gzip -dc yourmodule.tar.gz | tar -xof - + gzip -dc yourmodule.tar.gz | tar -xf - B. UNPACK -Unpack the result with C<tar -xof yourmodule.tar> +Unpack the result with C<tar -xf yourmodule.tar> C. BUILD diff --git a/gnu/usr.bin/perl/pod/perlop.pod b/gnu/usr.bin/perl/pod/perlop.pod index 9b1319a7a6c..34835130469 100644 --- a/gnu/usr.bin/perl/pod/perlop.pod +++ b/gnu/usr.bin/perl/pod/perlop.pod @@ -1618,7 +1618,7 @@ and although they often accept just C<"\012">, they seldom tolerate just C<"\015">. If you get in the habit of using C<"\n"> for networking, you may be burned some day. X<newline> X<line terminator> X<eol> X<end of line> -X<\n> X<\r> X<\r\n> +X<\r> For constructs that do interpolate, variables beginning with "C<$>" or "C<@>" are interpolated. Subscripted variables such as C<$a[3]> or diff --git a/gnu/usr.bin/perl/pp.c b/gnu/usr.bin/perl/pp.c index 4a2cde05e03..d95832a3368 100644 --- a/gnu/usr.bin/perl/pp.c +++ b/gnu/usr.bin/perl/pp.c @@ -3130,12 +3130,13 @@ PP(pp_srand) "Integer overflow in srand"); anum = UV_MAX; } + (void)srand48_deterministic((Rand_seed_t)anum); } else { anum = seed(); + (void)seedDrand01((Rand_seed_t)anum); } - (void)seedDrand01((Rand_seed_t)anum); PL_srand_called = TRUE; if (anum) XPUSHu(anum); diff --git a/gnu/usr.bin/perl/regen/lib_cleanup.pl b/gnu/usr.bin/perl/regen/lib_cleanup.pl index c9d6e434bd4..d43b4b222f8 100644 --- a/gnu/usr.bin/perl/regen/lib_cleanup.pl +++ b/gnu/usr.bin/perl/regen/lib_cleanup.pl @@ -74,6 +74,12 @@ foreach my $file (@ext) { $package = $1; last; } + elsif (/^\s*package\s*$/) { + # If they're hiding their package name, we ignore them + ++$ignore{"/$path"}; + $package=''; + last; + } } close $fh or die "Can't close $file: $!"; diff --git a/gnu/usr.bin/perl/shlib_version b/gnu/usr.bin/perl/shlib_version index 94727e17b3a..7c92aff4893 100644 --- a/gnu/usr.bin/perl/shlib_version +++ b/gnu/usr.bin/perl/shlib_version @@ -1,2 +1,2 @@ major=18 -minor=0 +minor=1 diff --git a/gnu/usr.bin/perl/t/lib/h2ph.pht b/gnu/usr.bin/perl/t/lib/h2ph.pht index f068d6dae46..cda8d21051c 100644 --- a/gnu/usr.bin/perl/t/lib/h2ph.pht +++ b/gnu/usr.bin/perl/t/lib/h2ph.pht @@ -90,10 +90,6 @@ unless(defined(&_H2PH_H_)) { } eval("sub flim () { 0; }") unless defined(&flim); eval("sub flam () { 1; }") unless defined(&flam); - eval 'sub blli_in_use { - my($blli) = @_; - eval q({ ($blli->{l2_proto}) || ($blli->{l3_proto}); }); - }' unless defined(&blli_in_use); eval 'sub multiline () {"multilinestring";}' unless defined(&multiline); } 1; diff --git a/gnu/usr.bin/perl/t/op/getppid.t b/gnu/usr.bin/perl/t/op/getppid.t index a8d0f2cb3b8..e3175a80c35 100755 --- a/gnu/usr.bin/perl/t/op/getppid.t +++ b/gnu/usr.bin/perl/t/op/getppid.t @@ -97,7 +97,7 @@ sub fork_and_retrieve { } } else { # Fudge it by waiting a bit more: - sleep 2; + sleep 3; } my $ppid2 = getppid(); print $w "$how,$ppid1,$ppid2\n"; diff --git a/gnu/usr.bin/perl/t/porting/customized.dat b/gnu/usr.bin/perl/t/porting/customized.dat index defeae11275..09b833d4380 100644 --- a/gnu/usr.bin/perl/t/porting/customized.dat +++ b/gnu/usr.bin/perl/t/porting/customized.dat @@ -1,3 +1,4 @@ +Digest::MD5 cpan/Digest-MD5/t/files.t f8fe234035918d3b7324eba05f73e7e903a45ca0 Archive::Tar cpan/Archive-Tar/bin/ptar 5e9f3c6f565114193d98847ed8569cd0010c229c Archive::Tar cpan/Archive-Tar/bin/ptardiff 5a9f4c01a0390bf98da7e63f1c0bbf5bc74d12c7 Archive::Tar cpan/Archive-Tar/bin/ptargrep eb74056c434acf314ac5a122e33bdd2ef99e6edb @@ -42,7 +43,7 @@ ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm 1f5eb772eed ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm de777d7809c0d73e5d4622a29921731c7e5dff48 ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm 01e8f08a82b5304009574e3ac0892b4066ff7639 ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm 5340052b58557a6764f5ac9f8b807fefec404a06 -ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm 3c3b93f431b0a51b9592b3d69624dbf5409f6f74 +ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm 20a9e08add92f04ee97084dbc48876c18622613b ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm 40397f4cd2d49700b80b4ef490da98add24c5b37 ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm 147e97fbabb74841f0733dbd5d1b9f3fa51f87c1 ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm 3f13ed7045ff3443bcb4dd6c95c98b9bd705820f @@ -56,8 +57,8 @@ ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/NoXS.pm 371cdff ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/prereq.t 53bda2c549fd13a6b6c13a070ca6bc79883081c0 ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/vstrings.t 90035a2bdbf45f15b9c3196d072d7cba7e662871 File::Fetch cpan/File-Fetch/lib/File/Fetch.pm bd0b64a1d8ee2ffac39e017f9fa9f78f95514b4d -File::Path cpan/File-Path/lib/File/Path.pm fd8ce4420a0c113d3f47dd3223859743655c1da8 -File::Path cpan/File-Path/t/Path_win32.t 94b9276557ce7f80b91f6fd9bfa7a0cd9bf9683e +File::Path cpan/File-Path/lib/File/Path.pm 7837c0a6c26609714b4fad0deeb82808409b83fe +File::Path cpan/File-Path/t/Path_win32.t bec8cc294d10f141ecdb7f165ef297a2dc27ba2f HTTP::Tiny cpan/HTTP-Tiny/lib/HTTP/Tiny.pm 3c899ab6938b588f6a2823a6aa59edc81fc2a387 IO-Compress cpan/IO-Compress/bin/zipdetails 381ba2a6ae5bd21c8d2e994316e3e13f2f0a4f41 IO-Compress cpan/IO-Compress/lib/Compress/Zlib.pm 58ddedd36889463706d4060589d0c5e6dc497b86 @@ -160,6 +161,7 @@ Test::Harness cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm bf1fbfff9720330 Test::Harness cpan/Test-Harness/lib/Test/Harness.pm da2d76ba673372da129060c9d0adb8cf0d91f9f7 autodie cpan/autodie/t/mkdir.t 9e70d2282a3cc7d76a78bf8144fccba20fb37dac bignum cpan/bignum/lib/bigint.pm 56330354995409dab5073ea92d749f8727e265db +version vutil.c 45ff345c3d8424ba63e130a223848f5b336bd87b bignum cpan/bignum/lib/bignum.pm e999973f78e6be12282c11bb6328246b31a9576b bignum cpan/bignum/lib/bigrat.pm 7fccc9df30e43dbbae6e5ea91b26c8046545c9a9 bignum cpan/bignum/lib/Math/BigFloat/Trace.pm a6b4b995e18f4083252e6dc72e9bef69671893dd diff --git a/gnu/usr.bin/perl/t/porting/dual-life.t b/gnu/usr.bin/perl/t/porting/dual-life.t index d7d62d717d5..9aa60c2ea6f 100644 --- a/gnu/usr.bin/perl/t/porting/dual-life.t +++ b/gnu/usr.bin/perl/t/porting/dual-life.t @@ -24,6 +24,12 @@ use File::Spec::Functions; # Exceptions that are found in dual-life bin dirs but aren't # installed by default; some occur only during testing: my $not_installed = qr{^(?: + \.\./cpan/Archive-Tar/bin/ptar.* + | + \.\./cpan/JSON-PP/bin/json_pp + | + \.\./cpan/IO-Compress/bin/zipdetails + | \.\./cpan/Encode/bin/u(?:cm(?:2table|lint|sort)|nidump) | \.\./cpan/Module-(?:Metadata|Build) diff --git a/gnu/usr.bin/perl/t/re/speed.t b/gnu/usr.bin/perl/t/re/speed.t index 648f2e9b749..0a32b5c9237 100644 --- a/gnu/usr.bin/perl/t/re/speed.t +++ b/gnu/usr.bin/perl/t/re/speed.t @@ -41,7 +41,7 @@ run_tests() unless caller; sub run_tests { - watchdog(($::running_as_thread && $::running_as_thread) ? 150 : 225); + watchdog(($::running_as_thread && $::running_as_thread) ? 150 : 540); { # [perl #120446] @@ -150,7 +150,7 @@ PROG my $substr= substr( $str, 1 ); 1 while $substr=~m/0/g; $elapsed += time; - ok( $elapsed <= 1, "should not COW on long string with substr and m//g"); + ok( $elapsed <= 2, "should not COW on long string with substr and m//g"); } diff --git a/gnu/usr.bin/perl/util.c b/gnu/usr.bin/perl/util.c index b64e87dd32f..72af251dd3c 100644 --- a/gnu/usr.bin/perl/util.c +++ b/gnu/usr.bin/perl/util.c @@ -4649,6 +4649,9 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) U32 Perl_seed(pTHX) { +#if defined(__OpenBSD__) + return arc4random(); +#else /* * This is really just a quick hack which grabs various garbage * values. It really should be a real hash algorithm which @@ -4717,6 +4720,7 @@ Perl_seed(pTHX) u += SEED_C5 * (U32)PTR2UV(&when); #endif return u; +#endif } void diff --git a/gnu/usr.bin/perl/utils.lst b/gnu/usr.bin/perl/utils.lst index 216a9d0b557..13384932674 100644 --- a/gnu/usr.bin/perl/utils.lst +++ b/gnu/usr.bin/perl/utils.lst @@ -11,19 +11,13 @@ utils/encguess utils/h2ph utils/h2xs utils/instmodsh -utils/json_pp utils/libnetcfg -utils/perlbug # link = utils/perlthanks +utils/perlbug utils/perldoc utils/perlivp utils/piconv utils/pl2pm utils/pod2html utils/prove -utils/ptar -utils/ptardiff -utils/ptargrep -utils/shasum utils/splain utils/xsubpp -utils/zipdetails diff --git a/gnu/usr.bin/perl/utils/Makefile.PL b/gnu/usr.bin/perl/utils/Makefile.PL index 27c371f82a8..640dac255bf 100644 --- a/gnu/usr.bin/perl/utils/Makefile.PL +++ b/gnu/usr.bin/perl/utils/Makefile.PL @@ -35,9 +35,9 @@ print $fh <<'EOT'; # Files to be built with variable substitution after miniperl is # available. Dependencies handled manually below (for now). -pl = c2ph.PL corelist.PL cpan.PL h2ph.PL h2xs.PL instmodsh.PL json_pp.PL perlbug.PL perldoc.PL perlivp.PL pl2pm.PL prove.PL ptar.PL ptardiff.PL ptargrep.PL shasum.PL splain.PL libnetcfg.PL piconv.PL enc2xs.PL encguess.PL xsubpp.PL pod2html.PL zipdetails.PL -plextract = c2ph corelist cpan h2ph h2xs instmodsh json_pp perlbug perldoc perlivp pl2pm prove ptar ptardiff ptargrep shasum splain libnetcfg piconv enc2xs encguess xsubpp pod2html zipdetails -plextractexe = ./c2ph ./corelist ./cpan ./h2ph ./h2xs ./json_pp ./instmodsh ./perlbug ./perldoc ./perlivp ./pl2pm ./prove ./ptar ./ptardiff ./ptargrep ./shasum ./splain ./libnetcfg ./piconv ./enc2xs ./encguess ./xsubpp ./pod2html ./zipdetails +pl = c2ph.PL corelist.PL cpan.PL h2ph.PL h2xs.PL instmodsh.PL perlbug.PL perldoc.PL perlivp.PL pl2pm.PL prove.PL splain.PL libnetcfg.PL piconv.PL enc2xs.PL encguess.PL xsubpp.PL pod2html.PL +plextract = c2ph corelist cpan h2ph h2xs instmodsh perlbug perldoc perlivp pl2pm prove splain libnetcfg piconv enc2xs encguess xsubpp pod2html +plextractexe = ./c2ph ./corelist ./cpan ./h2ph ./h2xs ./instmodsh ./perlbug ./perldoc ./perlivp ./pl2pm ./prove ./splain ./libnetcfg ./piconv ./enc2xs ./encguess ./xsubpp ./pod2html all: $(plextract) @@ -56,8 +56,6 @@ h2xs: h2xs.PL ../config.sh instmodsh: instmodsh.PL ../config.sh -json_pp: json_pp.PL ../config.sh - perlbug: perlbug.PL ../config.sh ../patchlevel.h perldoc: perldoc.PL ../config.sh @@ -66,16 +64,8 @@ perlivp: perlivp.PL ../config.sh prove: prove.PL ../config.sh -ptar: ptar.PL ../config.sh - -ptardiff: ptardiff.PL ../config.sh - -ptargrep: ptargrep.PL ../config.sh - pl2pm: pl2pm.PL ../config.sh -shasum: shasum.PL ../config.sh - splain: splain.PL ../config.sh ../lib/diagnostics.pm libnetcfg: libnetcfg.PL ../config.sh @@ -88,8 +78,6 @@ enc2xs: encguess.PL ../config.sh xsubpp: xsubpp.PL ../config.sh -zipdetails: zipdetails.PL ../config.sh - pod2html: pod2html.PL ../config.sh ../ext/Pod-Html/bin/pod2html clean: diff --git a/gnu/usr.bin/perl/utils/h2ph.PL b/gnu/usr.bin/perl/utils/h2ph.PL index 2523c0a6545..6d743718c63 100644 --- a/gnu/usr.bin/perl/utils/h2ph.PL +++ b/gnu/usr.bin/perl/utils/h2ph.PL @@ -573,7 +573,7 @@ sub next_line $in =~ s/\?\?</{/g; # | ??<| {| $in =~ s/\?\?>/}/g; # | ??>| }| } - if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) { + if ($in =~ s/^\#ifdef __LANGUAGE_PASCAL__//) { # Tru64 disassembler.h evilness: mixed C and Pascal. while (<IN>) { last if /^\#endif/; @@ -581,8 +581,8 @@ sub next_line $in = ""; next READ; } - if ($in =~ /^extern inline / && # Inlined assembler. - $^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) { + # Skip inlined functions in headers + if ($in =~ s/^(extern|static) (__inline__|inline) .*[^;]\s*$//) { while (<IN>) { last if /^}/; } diff --git a/gnu/usr.bin/perl/utils/perlbug.PL b/gnu/usr.bin/perl/utils/perlbug.PL index ae8c3430521..931fcd86851 100644 --- a/gnu/usr.bin/perl/utils/perlbug.PL +++ b/gnu/usr.bin/perl/utils/perlbug.PL @@ -346,15 +346,14 @@ sub Query { This program provides an easy way to send a thank-you message back to the authors and maintainers of perl. -If you wish to submit a bug report, please run it without the -T flag -(or run the program perlbug rather than perlthanks) +If you wish to submit a bug report, please run it without the -T flag. EOF } else { paraprint <<"EOF"; This program provides an easy way to create a message reporting a bug in the core perl distribution (along with tests or patches) to the volunteers who maintain perl at $address. To send a thank-you -note to $thanksaddress instead of a bug report, please run 'perlthanks'. +note to $thanksaddress instead of a bug report, please use the -T flag. Please do not use $0 to send test messages, test whether perl works, or to report bugs in perl modules from CPAN. @@ -1245,8 +1244,6 @@ S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-A> ]> S<[ B<-h> ]> S<[ B<-T> ]> B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]> S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]> -B<perlthanks> - =head1 DESCRIPTION @@ -1399,8 +1396,8 @@ description of what's wrong is fine. =item Can you use C<perlbug> to submit a thank-you note? -Yes, you can do this by either using the C<-T> option, or by invoking -the program as C<perlthanks>. Thank-you notes are good. It makes people +Yes, you can do this by using the C<-T> option. +Thank-you notes are good. It makes people smile. =back diff --git a/gnu/usr.bin/perl/vutil.c b/gnu/usr.bin/perl/vutil.c index 610c03c4463..de3367e7dca 100644 --- a/gnu/usr.bin/perl/vutil.c +++ b/gnu/usr.bin/perl/vutil.c @@ -609,7 +609,11 @@ VER_NV: /* may get too much accuracy */ char tbuf[64]; +#ifdef __vax__ + SV *sv = SvNVX(ver) > 10e37 ? newSV(64) : 0; +#else SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0; +#endif char *buf; #if PERL_VERSION_GE(5,19,0) diff --git a/gnu/usr.bin/perl/win32/Makefile b/gnu/usr.bin/perl/win32/Makefile index cec0a002cf6..cacdf81e620 100644 --- a/gnu/usr.bin/perl/win32/Makefile +++ b/gnu/usr.bin/perl/win32/Makefile @@ -1288,6 +1288,7 @@ distclean: realclean -if exist $(LIBDIR)\MIME rmdir /s /q $(LIBDIR)\MIME -if exist $(LIBDIR)\Module rmdir /s /q $(LIBDIR)\Module -if exist $(LIBDIR)\Net\FTP rmdir /s /q $(LIBDIR)\Net\FTP + -if exist $(LIBDIR)\OpenBSD rmdir /s /q $(LIBDIR)\OpenBSD -if exist $(LIBDIR)\Params rmdir /s /q $(LIBDIR)\Params -if exist $(LIBDIR)\Parse rmdir /s /q $(LIBDIR)\Parse -if exist $(LIBDIR)\Perl rmdir /s /q $(LIBDIR)\Perl diff --git a/gnu/usr.bin/perl/win32/makefile.mk b/gnu/usr.bin/perl/win32/makefile.mk index 9823e63a0b4..fb769a723a4 100644 --- a/gnu/usr.bin/perl/win32/makefile.mk +++ b/gnu/usr.bin/perl/win32/makefile.mk @@ -1583,6 +1583,7 @@ distclean: realclean -if exist $(LIBDIR)\MIME rmdir /s /q $(LIBDIR)\MIME -if exist $(LIBDIR)\Module rmdir /s /q $(LIBDIR)\Module -if exist $(LIBDIR)\Net\FTP rmdir /s /q $(LIBDIR)\Net\FTP + -if exist $(LIBDIR)\OpenBSD rmdir /s /q $(LIBDIR)\OpenBSD -if exist $(LIBDIR)\Params rmdir /s /q $(LIBDIR)\Params -if exist $(LIBDIR)\Parse rmdir /s /q $(LIBDIR)\Parse -if exist $(LIBDIR)\Perl rmdir /s /q $(LIBDIR)\Perl |