From 8735f961b5c4154e78ad5dfd924f8fb88feb0718 Mon Sep 17 00:00:00 2001 From: DongHun Kwak Date: Wed, 28 Jun 2017 10:43:19 +0900 Subject: [PATCH] Imported Upstream version 5.23.4 Change-Id: I57ae044ebb1c4967474d3c1fe8bec15e2b8db44d Signed-off-by: DongHun Kwak --- AUTHORS | 1 + Configure | 164 +--- Cross/config.sh-arm-linux | 57 +- Cross/config.sh-arm-linux-n770 | 57 +- INSTALL | 30 +- MANIFEST | 71 +- META.json | 3 +- META.yml | 3 +- Makefile.SH | 11 +- NetWare/Makefile | 4 +- NetWare/config.wc | 17 - NetWare/config_H.wc | 153 +--- Porting/Glossary | 110 --- Porting/Maintainers.pl | 82 +- Porting/README.pod | 5 + Porting/checkcfguse.pl | 99 +++ Porting/config.sh | 59 +- Porting/config_H | 162 +--- Porting/epigraphs.pod | 12 + Porting/exec-bit.txt | 1 + Porting/makerel | 2 + Porting/perldelta_template.pod | 2 +- Porting/release_schedule.pod | 2 +- Porting/todo.pod | 4 +- README.haiku | 4 +- README.macosx | 8 +- README.os2 | 2 +- README.vms | 4 +- README.win32 | 12 +- XSUB.h | 1 + autodoc.pl | 13 +- av.c | 26 +- charclass_invlists.h | 2 +- config_h.SH | 144 ---- configure.com | 34 +- cop.h | 4 + cpan/Compress-Raw-Bzip2/Bzip2.xs | 19 +- cpan/Compress-Raw-Bzip2/bzip2-src/blocksort.c | 8 +- cpan/Compress-Raw-Bzip2/bzip2-src/bzlib_private.h | 4 +- cpan/Compress-Raw-Bzip2/bzip2-src/crctable.c | 2 +- cpan/Compress-Raw-Bzip2/bzip2-src/randtable.c | 2 +- cpan/Compress-Raw-Bzip2/lib/Compress/Raw/Bzip2.pm | 4 +- cpan/Compress-Raw-Bzip2/t/000prereq.t | 2 +- cpan/Compress-Raw-Zlib/Zlib.xs | 5 +- cpan/Compress-Raw-Zlib/lib/Compress/Raw/Zlib.pm | 4 +- cpan/Compress-Raw-Zlib/zlib-src/deflate.c | 2 +- cpan/Compress-Raw-Zlib/zlib-src/deflate.h | 2 +- cpan/Compress-Raw-Zlib/zlib-src/inflate.c | 2 +- cpan/Compress-Raw-Zlib/zlib-src/trees.c | 6 +- cpan/Devel-PPPort/PPPort_pm.PL | 2 +- cpan/Devel-PPPort/parts/inc/misc | 2 +- cpan/Devel-PPPort/soak | 2 +- cpan/Devel-PPPort/t/misc.t | 2 +- cpan/Encode/Encode.pm | 4 +- cpan/Encode/Makefile.PL | 8 +- cpan/Encode/lib/Encode/Supported.pod | 2 +- cpan/File-Path/lib/File/Path.pm | 25 +- cpan/File-Path/t/FilePathTest.pm | 112 +++ cpan/File-Path/t/Path.t | 646 +++++++--------- cpan/File-Path/t/Path_root.t | 123 +++ cpan/File-Path/t/Path_win32.t | 29 + cpan/IO-Compress/Makefile.PL | 2 +- cpan/IO-Compress/lib/Compress/Zlib.pm | 14 +- cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm | 6 +- .../IO-Compress/lib/IO/Compress/Adapter/Deflate.pm | 6 +- .../lib/IO/Compress/Adapter/Identity.pm | 4 +- cpan/IO-Compress/lib/IO/Compress/Base.pm | 6 +- cpan/IO-Compress/lib/IO/Compress/Base/Common.pm | 2 +- cpan/IO-Compress/lib/IO/Compress/Bzip2.pm | 12 +- cpan/IO-Compress/lib/IO/Compress/Deflate.pm | 12 +- cpan/IO-Compress/lib/IO/Compress/FAQ.pod | 15 +- cpan/IO-Compress/lib/IO/Compress/Gzip.pm | 14 +- cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm | 2 +- cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm | 14 +- cpan/IO-Compress/lib/IO/Compress/Zip.pm | 71 +- cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm | 2 +- cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm | 2 +- cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm | 4 +- .../lib/IO/Uncompress/Adapter/Bunzip2.pm | 6 +- .../lib/IO/Uncompress/Adapter/Identity.pm | 6 +- .../lib/IO/Uncompress/Adapter/Inflate.pm | 6 +- cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm | 20 +- .../IO-Compress/lib/IO/Uncompress/AnyUncompress.pm | 40 +- cpan/IO-Compress/lib/IO/Uncompress/Base.pm | 6 +- cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm | 10 +- cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm | 14 +- cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm | 10 +- cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm | 12 +- cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm | 18 +- cpan/IO-Compress/t/000prereq.t | 2 +- .../lib/Math/BigInt/FastCalc.pm | 69 +- cpan/Math-BigInt/lib/Math/BigFloat.pm | 107 ++- cpan/Math-BigInt/lib/Math/BigInt.pm | 169 ++-- cpan/Math-BigInt/lib/Math/BigInt/Calc.pm | 2 +- cpan/Math-BigInt/lib/Math/BigInt/CalcEmu.pm | 2 +- cpan/Math-BigInt/t/bare_mbf.t | 2 +- cpan/Math-BigInt/t/bare_mbi.t | 2 +- cpan/Math-BigInt/t/bigfltpm.inc | 31 +- cpan/Math-BigInt/t/bigfltpm.t | 9 +- cpan/Math-BigInt/t/bigintpm.inc | 297 +++++--- cpan/Math-BigInt/t/bigintpm.t | 2 +- cpan/Math-BigInt/t/biglog.t | 6 +- cpan/Math-BigInt/t/bigroot.t | 6 +- cpan/Math-BigInt/t/blog-mbf.t | 264 +++++++ cpan/Math-BigInt/t/blog-mbi.t | 264 +++++++ cpan/Math-BigInt/t/mbimbf.t | 4 +- cpan/Math-BigInt/t/objectify_mbf.t | 90 +++ cpan/Math-BigInt/t/objectify_mbi.t | 130 ++++ cpan/Math-BigInt/t/sub_mbf.t | 2 +- cpan/Math-BigInt/t/sub_mbi.t | 2 +- cpan/Math-BigInt/t/with_sub.t | 2 +- cpan/Module-Metadata/lib/Module/Metadata.pm | 300 +++++--- cpan/Module-Metadata/t/extract-package.t | 146 ++++ cpan/Module-Metadata/t/extract-version.t | 683 +++++++++++++++++ cpan/Module-Metadata/t/lib/GeneratePackage.pm | 38 + cpan/Module-Metadata/t/metadata.t | 366 +-------- cpan/Perl-OSType/lib/Perl/OSType.pm | 11 +- cpan/Socket/Socket.pm | 2 +- cpan/Socket/Socket.xs | 43 +- cpan/Unicode-Normalize/Normalize.pm | 83 +- cpan/Unicode-Normalize/t/func.t | 77 +- {dist => cpan}/bignum/lib/Math/BigFloat/Trace.pm | 2 +- {dist => cpan}/bignum/lib/Math/BigInt/Trace.pm | 2 +- {dist => cpan}/bignum/lib/bigint.pm | 113 ++- {dist => cpan}/bignum/lib/bignum.pm | 2 +- {dist => cpan}/bignum/lib/bigrat.pm | 2 +- cpan/bignum/t/auth-bigint-hex.t | 49 ++ cpan/bignum/t/auth-bigint-oct.t | 49 ++ {dist => cpan}/bignum/t/big_e_pi.t | 0 {dist => cpan}/bignum/t/bigexp.t | 0 {dist => cpan}/bignum/t/bigint.t | 0 {dist => cpan}/bignum/t/bignum.t | 0 {dist => cpan}/bignum/t/bigrat.t | 0 {dist => cpan}/bignum/t/bii_e_pi.t | 0 {dist => cpan}/bignum/t/biinfnan.t | 0 {dist => cpan}/bignum/t/bir_e_pi.t | 0 {dist => cpan}/bignum/t/bn_lite.t | 0 {dist => cpan}/bignum/t/bninfnan.t | 0 {dist => cpan}/bignum/t/br_lite.t | 0 {dist => cpan}/bignum/t/brinfnan.t | 0 {dist => cpan}/bignum/t/in_effect.t | 0 {dist => cpan}/bignum/t/infnan.inc | 0 {dist => cpan}/bignum/t/option_a.t | 0 {dist => cpan}/bignum/t/option_l.t | 0 {dist => cpan}/bignum/t/option_p.t | 0 {dist => cpan}/bignum/t/overrides.t | 0 {dist => cpan}/bignum/t/ratopt_a.t | 0 {dist => cpan}/bignum/t/scope_f.t | 0 {dist => cpan}/bignum/t/scope_i.t | 0 {dist => cpan}/bignum/t/scope_r.t | 0 cpan/experimental/lib/experimental.pm | 14 +- cpan/experimental/t/basic.t | 8 +- dist/ExtUtils-CBuilder/Changes | 6 + dist/ExtUtils-CBuilder/Makefile.PL | 5 +- dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm | 19 +- .../lib/ExtUtils/CBuilder/Base.pm | 3 +- .../lib/ExtUtils/CBuilder/Platform/Unix.pm | 9 +- .../lib/ExtUtils/CBuilder/Platform/VMS.pm | 3 +- .../lib/ExtUtils/CBuilder/Platform/Windows.pm | 2 +- .../lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm | 5 +- .../lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm | 5 +- .../lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm | 5 +- .../lib/ExtUtils/CBuilder/Platform/aix.pm | 3 +- .../lib/ExtUtils/CBuilder/Platform/android.pm | 3 +- .../lib/ExtUtils/CBuilder/Platform/cygwin.pm | 3 +- .../lib/ExtUtils/CBuilder/Platform/darwin.pm | 3 +- .../lib/ExtUtils/CBuilder/Platform/dec_osf.pm | 3 +- .../lib/ExtUtils/CBuilder/Platform/os2.pm | 3 +- dist/IO/IO.pm | 2 +- dist/IO/IO.xs | 5 +- dist/IO/lib/IO/Poll.pm | 4 +- dist/IO/poll.h | 2 + dist/IO/t/io_poll.t | 11 +- dist/Module-CoreList/Changes | 3 + dist/Module-CoreList/lib/Module/CoreList.pm | 103 ++- .../lib/Module/CoreList/TieHashDelta.pm | 2 +- dist/Module-CoreList/lib/Module/CoreList/Utils.pm | 9 +- dist/if/Changes | 50 ++ dist/if/if.pm | 9 +- doio.c | 19 +- doop.c | 6 +- embed.fnc | 13 +- embed.h | 3 +- ext/B/B.pm | 2 +- ext/B/B.xs | 10 +- ext/DynaLoader/DynaLoader_pm.PL | 3 +- ext/DynaLoader/dl_dlopen.xs | 9 +- ext/DynaLoader/t/DynaLoader.t | 2 +- ext/File-Glob/t/rt114984.t | 3 +- ext/POSIX/lib/POSIX.pm | 4 +- ext/POSIX/t/strerror_errno.t | 7 + ext/PerlIO-encoding/encoding.pm | 2 +- ext/PerlIO-encoding/encoding.xs | 25 +- ext/PerlIO-encoding/t/threads.t | 35 + ext/SDBM_File/sdbm.c | 2 + ext/SDBM_File/sdbm.h | 6 +- ext/XS-APItest/APItest.pm | 2 +- ext/XS-APItest/APItest.xs | 265 ++++++- ext/XS-APItest/t/extend.t | 68 ++ ext/XS-APItest/t/hash.t | 21 +- ext/XS-APItest/t/newDEFSVOP.t | 22 +- ext/XS-APItest/t/underscore_length.t | 10 +- ext/XS-APItest/t/xsub_h.t | 31 + ext/arybase/t/akeys.t | 19 +- ext/arybase/t/aslice.t | 19 +- ext/arybase/t/lslice.t | 15 +- gv.c | 4 + handy.h | 14 +- hints/catamount.sh | 4 +- hints/darwin.sh | 116 ++- hints/irix_6.sh | 3 + hints/linux-android.sh | 12 - hv.c | 10 +- hv_func.h | 6 +- intrpvar.h | 19 +- iperlsys.h | 6 +- lib/B/Deparse.t | 12 +- lib/B/Op_private.pm | 10 +- lib/ExtUtils/typemap | 6 +- lib/unicore/mktables | 24 +- lib/utf8_heavy.pl | 4 +- lib/warnings.pm | 107 ++- make_ext.pl | 4 +- makedef.pl | 1 + mg.c | 14 +- op.c | 77 +- opcode.h | 577 +++++++------- pad.c | 51 +- patchlevel.h | 4 +- perl.c | 51 +- perl.h | 18 +- perlio.c | 6 + perlvars.h | 9 +- perly.act | 847 ++++++++++----------- perly.h | 64 +- perly.tab | 99 +-- perly.y | 8 +- plan9/config.plan9 | 153 +--- plan9/config_h.sample | 143 ---- plan9/config_sh.sample | 55 +- pod/.gitignore | 2 +- pod/perl.pod | 1 + pod/perl5233delta.pod | 404 ++++++++++ pod/perldebguts.pod | 5 +- pod/perldelta.pod | 437 +++++++---- pod/perldiag.pod | 59 +- pod/perlfunc.pod | 14 +- pod/perlgit.pod | 5 + pod/perlhacktips.pod | 15 + pod/perlhist.pod | 1 + pod/perlport.pod | 4 +- pod/perlre.pod | 57 +- pod/perlrecharclass.pod | 5 +- pod/perlsub.pod | 3 +- pod/perlsyn.pod | 9 +- pod/perltie.pod | 15 +- pod/perlvar.pod | 10 +- pp.c | 64 +- pp.h | 47 +- pp_ctl.c | 46 +- pp_hot.c | 30 +- pp_sys.c | 18 +- proto.h | 17 +- regcharclass.h | 2 +- regcomp.c | 680 ++++++++++------- regcomp.sym | 5 +- regen/op_private | 10 +- regen/regcomp.pl | 760 +++++++++++------- regen/warnings.pl | 19 +- regexec.c | 251 +++--- regnodes.h | 12 +- scope.c | 4 + sv.c | 20 +- sv.h | 6 +- symbian/config.sh | 17 - t/comp/uproto.t | 31 +- t/io/errno.t | 6 +- t/lib/warnings/9uninit | 82 +- t/lib/warnings/op | 14 - t/lib/warnings/regexec | 1 + t/lib/warnings/utf8 | 90 +-- t/op/coreamp.t | 33 +- t/op/exec.t | 3 +- t/op/goto.t | 34 +- t/op/magic.t | 23 +- t/op/mkdir.t | 12 +- t/op/mydef.t | 208 +---- t/op/override.t | 13 +- t/op/pack.t | 38 +- t/op/reverse.t | 15 +- t/op/sigdispatch.t | 5 +- t/op/signatures.t | 18 - t/op/sprintf2.t | 10 + t/op/state.t | 18 +- t/op/sub_lval.t | 16 +- t/op/switch.t | 96 +-- t/perf/benchmarks | 88 +++ t/porting/customized.dat | 9 +- t/porting/known_pod_issues.dat | 2 +- t/porting/maintainers.t | 12 +- t/re/pat.t | 17 +- t/re/pat_advanced.t | 16 +- t/re/pat_rt_report.t | 3 +- t/re/qr.t | 22 +- t/re/re_tests | 25 + t/re/reg_mesg.t | 11 +- t/re/regex_sets.t | 22 +- t/re/regexp_unicode_prop.t | 9 +- t/re/subst.t | 25 +- uconfig.h | 148 +--- uconfig.sh | 17 - uconfig64.sh | 17 - utf8.c | 16 +- util.c | 237 +++--- vms/descrip_mms.template | 2 +- vms/vms.c | 163 +++- vms/vmsish.h | 2 + warnings.h | 27 +- win32/GNUmakefile | 6 +- win32/Makefile | 32 +- win32/config.ce | 17 - win32/config.gc | 17 - win32/config.vc | 17 - win32/config_H.ce | 143 ---- win32/config_H.gc | 144 ---- win32/config_H.vc | 144 ---- win32/makefile.mk | 29 +- win32/perlhost.h | 22 +- win32/pod.mak | 4 + win32/win32.c | 122 ++- win32/win32.h | 14 +- win32/wince.c | 2 +- write_buildcustomize.pl | 1 - 333 files changed, 8610 insertions(+), 6429 deletions(-) create mode 100755 Porting/checkcfguse.pl create mode 100644 cpan/File-Path/t/FilePathTest.pm create mode 100644 cpan/File-Path/t/Path_root.t create mode 100644 cpan/File-Path/t/Path_win32.t create mode 100644 cpan/Math-BigInt/t/blog-mbf.t create mode 100644 cpan/Math-BigInt/t/blog-mbi.t create mode 100644 cpan/Math-BigInt/t/objectify_mbf.t create mode 100644 cpan/Math-BigInt/t/objectify_mbi.t create mode 100644 cpan/Module-Metadata/t/extract-package.t create mode 100644 cpan/Module-Metadata/t/extract-version.t create mode 100644 cpan/Module-Metadata/t/lib/GeneratePackage.pm rename {dist => cpan}/bignum/lib/Math/BigFloat/Trace.pm (98%) rename {dist => cpan}/bignum/lib/Math/BigInt/Trace.pm (98%) rename {dist => cpan}/bignum/lib/bigint.pm (89%) rename {dist => cpan}/bignum/lib/bignum.pm (99%) rename {dist => cpan}/bignum/lib/bigrat.pm (99%) create mode 100644 cpan/bignum/t/auth-bigint-hex.t create mode 100644 cpan/bignum/t/auth-bigint-oct.t rename {dist => cpan}/bignum/t/big_e_pi.t (100%) rename {dist => cpan}/bignum/t/bigexp.t (100%) rename {dist => cpan}/bignum/t/bigint.t (100%) rename {dist => cpan}/bignum/t/bignum.t (100%) rename {dist => cpan}/bignum/t/bigrat.t (100%) rename {dist => cpan}/bignum/t/bii_e_pi.t (100%) rename {dist => cpan}/bignum/t/biinfnan.t (100%) rename {dist => cpan}/bignum/t/bir_e_pi.t (100%) rename {dist => cpan}/bignum/t/bn_lite.t (100%) rename {dist => cpan}/bignum/t/bninfnan.t (100%) rename {dist => cpan}/bignum/t/br_lite.t (100%) rename {dist => cpan}/bignum/t/brinfnan.t (100%) rename {dist => cpan}/bignum/t/in_effect.t (100%) rename {dist => cpan}/bignum/t/infnan.inc (100%) rename {dist => cpan}/bignum/t/option_a.t (100%) rename {dist => cpan}/bignum/t/option_l.t (100%) rename {dist => cpan}/bignum/t/option_p.t (100%) rename {dist => cpan}/bignum/t/overrides.t (100%) rename {dist => cpan}/bignum/t/ratopt_a.t (100%) rename {dist => cpan}/bignum/t/scope_f.t (100%) rename {dist => cpan}/bignum/t/scope_i.t (100%) rename {dist => cpan}/bignum/t/scope_r.t (100%) create mode 100644 dist/if/Changes create mode 100644 ext/PerlIO-encoding/t/threads.t create mode 100644 ext/XS-APItest/t/extend.t create mode 100644 pod/perl5233delta.pod diff --git a/AUTHORS b/AUTHORS index 451c707..ebd9222 100644 --- a/AUTHORS +++ b/AUTHORS @@ -1222,6 +1222,7 @@ Unicode Consortium Vadim Konovalov Valeriy E. Ushakov Vernon Lyon +Victor Adam Victor Efimov Viktor Turskyi Ville Skyttä diff --git a/Configure b/Configure index e12c8bb..6f2d4ff 100755 --- a/Configure +++ b/Configure @@ -496,10 +496,8 @@ d_fpclassl='' d_fpgetround='' d_fpos64_t='' d_frexpl='' -d_fs_data_s='' d_fseeko='' d_fsetpos='' -d_fstatfs='' d_fsync='' d_ftello='' d_ftime='' @@ -509,7 +507,6 @@ d_Gconvert='' d_getaddrinfo='' d_getcwd='' d_getespwnam='' -d_getfsstat='' d_getgrent='' d_getgrent_r='' getgrent_r_proto='' @@ -536,8 +533,6 @@ d_getitimer='' d_getlogin='' d_getlogin_r='' getlogin_r_proto='' -d_getmnt='' -d_getmntent='' d_getnameinfo='' d_getnbyaddr='' d_getnbyname='' @@ -591,7 +586,6 @@ d_gmtime_r='' gmtime_r_proto='' d_gnulibc='' gnulibc_version='' -d_hasmntopt='' d_htonl='' d_hypot='' d_ilogb='' @@ -822,12 +816,8 @@ d_sresgproto='' d_sresuproto='' d_stat='' d_statblks='' -d_statfs_f_flags='' -d_statfs_s='' d_static_inline='' perl_static_inline='' -d_fstatvfs='' -d_statvfs='' d_stdio_cnt_lval='' d_stdio_ptr_lval='' d_stdio_ptr_lval_nochange_cnt='' @@ -899,7 +889,6 @@ d_unordered='' d_unsetenv='' d_usleep='' d_usleepproto='' -d_ustat='' d_pseudofork='' d_vfork='' usevfork='' @@ -982,7 +971,6 @@ i_malloc='' i_mallocmalloc='' i_math='' i_memory='' -i_mntent='' d_gdbm_ndbm_h_uses_prototypes='' d_gdbmndbm_h_uses_prototypes='' d_ndbm='' @@ -1028,7 +1016,6 @@ i_syssockio='' i_syslog='' i_sysmman='' i_sysmode='' -i_sysmount='' i_sysndir='' i_sysparam='' i_syspoll='' @@ -1036,14 +1023,11 @@ i_sysresrc='' i_syssecrt='' i_sysselct='' i_sysstat='' -i_sysstatfs='' -i_sysstatvfs='' i_systimes='' i_systypes='' i_sysuio='' i_sysun='' i_sysutsname='' -i_sysvfs='' i_syswait='' i_sgtty='' i_termio='' @@ -1055,7 +1039,6 @@ i_systimek='' i_time='' timeincl='' i_unistd='' -i_ustat='' i_utime='' i_values='' i_stdarg='' @@ -5550,7 +5533,12 @@ esac : the following weeds options from ccflags that are of no interest to cpp case "$cppflags" in '') cppflags="$ccflags" ;; -*) cppflags="$cppflags $ccflags" ;; +*) set X $ccflags; shift + case " $cppflags " in + *" $1 "*) ;; # Try to avoid doubling the cppflags. + *) cppflags="$cppflags $ccflags" ;; + esac + ;; esac case "$gccversion" in 1*) cppflags="$cppflags -D__GNUC__" @@ -13328,7 +13316,7 @@ echo "Let's see what value errno gets from read() on a $o_nonblock file..." >&4 case "$eagain" in '') case "$d_fork:$d_pipe:$d_alarm" in - define:define) + define:define:define) $cat head.c > try.c $cat >>try.c < @@ -14086,20 +14074,6 @@ eval $inlibc set sys/param.h i_sysparam eval $inhdr -: see if this is a sys/mount.h system -set sys/mount.h i_sysmount -eval $inhdr - -: Check for fs_data_s -echo " " -echo "Checking to see if your system supports struct fs_data..." >&4 -set d_fs_data_s fs_data $i_systypes sys/types.h $i_sysparam sys/param.h $i_sysmount sys/mount.h -eval $hasstruct -case "$d_fs_data_s" in -"$define") echo "Yes, it does." ;; -*) echo "No, it doesn't." ;; -esac - : see if fseeko exists set fseeko d_fseeko eval $inlibc @@ -14111,19 +14085,6 @@ esac set fsetpos d_fsetpos eval $inlibc -: see if fstatfs exists -set fstatfs d_fstatfs -eval $inlibc - -: see if statvfs exists -set statvfs d_statvfs -eval $inlibc - -: see if fstatvfs exists -set fstatvfs d_fstatvfs -eval $inlibc - - : see if fsync exists set fsync d_fsync eval $inlibc @@ -14236,10 +14197,6 @@ eval $inlibc set getespwnam d_getespwnam eval $inlibc -: see if getfsstat exists -set getfsstat d_getfsstat -eval $inlibc - : see if getgrent exists set getgrent d_getgrent eval $inlibc @@ -14769,14 +14726,6 @@ case "$d_getlogin_r" in ;; esac -: see if getmnt exists -set getmnt d_getmnt -eval $inlibc - -: see if getmntent exists -set getmntent d_getmntent -eval $inlibc - : see if getnameinfo exists set getnameinfo d_getnameinfo eval $inlibc @@ -15633,10 +15582,6 @@ case "$d_gmtime_r" in ;; esac -: see if hasmntopt exists -set hasmntopt d_hasmntopt -eval $inlibc - : see if this is a netinet/in.h or sys/in.h system set netinet/in.h i_niin sys/in.h i_sysin eval $inhdr @@ -17160,16 +17105,21 @@ EOM set readlink d_readlink eval $inlibc -: Check if exe is symlink to abs path of executing program +: Check if there is a /proc symlink to the abs path of +: the executing program. We will honor hints of d_procselfexe=$undef +: or procselfexe being non-empty, otherwise will try to determine both +: if we have readlink. +: AmigaOS will attempt to mount proc: aka /proc, if /proc/... is +: referenced, and AmigaOS does not have a proc filesystem anyway. echo " " -procselfexe='' val="$undef" -case "$d_procselfexe" in -'') -case "$d_readlink" in - "$define") - : NetBSD first as /proc/self is a symlink to /proc/curproc, and it feels - : more tidy to avoid an extra level of symlink +if $test "X$d_procselfexe" = Xundef; then + procselfexe='' +elif $test "X$procselfexe" != X -a "X$procselfexe" != 'X '; then + val="$define" +elif $test "X$d_readlink" = Xdefine; then + : NetBSD first as /proc/self is a symlink to /proc/curproc, + : and it feels more tidy to avoid an extra level of symlink set NetBSD /proc/curproc/exe Linux /proc/self/exe FreeBSD /proc/curproc/file Solaris /proc/self/path/a.out while test $# -gt 0; do type=$1; try=$2 @@ -17185,13 +17135,10 @@ case "$d_readlink" in fi fi done - ;; -esac +fi $rm -f reflect set d_procselfexe eval $setvar -;; -esac : backward compatibility for d_hvfork if test X$d_hvfork != X; then @@ -18919,43 +18866,6 @@ echo "Checking to see if your struct stat has st_blocks field..." >&4 set d_statblks stat st_blocks $i_sysstat sys/stat.h eval $hasfield -: see if this is a sys/vfs.h system -set sys/vfs.h i_sysvfs -eval $inhdr - -: see if this is a sys/statfs.h system -set sys/statfs.h i_sysstatfs -eval $inhdr - -: Check for statfs_s -echo " " -echo "Checking to see if your system supports struct statfs..." >&4 -set d_statfs_s statfs $i_systypes sys/types.h $i_sysparam sys/param.h $i_sysmount sys/mount.h $i_sysvfs sys/vfs.h $i_sysstatfs sys/statfs.h -eval $hasstruct -case "$d_statfs_s" in -"$define") echo "Yes, it does." ;; -*) echo "No, it doesn't." ;; -esac - - -: see if struct statfs knows about f_flags -case "$d_statfs_s" in -define) - echo " " - echo "Checking to see if your struct statfs has f_flags field..." >&4 - set d_statfs_f_flags statfs f_flags $i_systypes sys/types.h $i_sysparam sys/param.h $i_sysmount sys/mount.h $i_sysvfs sys/vfs.h $i_sysstatfs sys/statfs.h - eval $hasfield - ;; -*) val="$undef" - set d_statfs_f_flags - eval $setvar - ;; -esac -case "$d_statfs_f_flags" in -"$define") echo "Yes, it does." ;; -*) echo "No, it doesn't." ;; -esac - : see what flavor, if any, of static inline is supported echo " " echo "Checking to see if your system supports static inline..." @@ -19909,10 +19819,6 @@ echo " " set d_usleepproto usleep $i_unistd unistd.h eval $hasproto -: see if ustat exists -set ustat d_ustat -eval $inlibc - : see if closedir exists set closedir d_closedir eval $inlibc @@ -22983,10 +22889,6 @@ else i_machcthr="$undef" fi -: see if this is a mntent.h system -set mntent.h i_mntent -eval $inhdr - : see if net/errno.h is available val='' set net/errno.h val @@ -23427,10 +23329,6 @@ eval $inhdr set sys/security.h i_syssecrt eval $inhdr -: see if this is a sys/statvfs.h system -set sys/statvfs.h i_sysstatvfs -eval $inhdr - : see if this is a sys/un.h system set sys/un.h i_sysun eval $inhdr @@ -23443,10 +23341,6 @@ eval $inhdr set sys/wait.h i_syswait eval $inhdr -: see if this is a ustat.h system -set ustat.h i_ustat -eval $inhdr - : see if this is an utime system set utime.h i_utime eval $inhdr @@ -24196,8 +24090,6 @@ d_frexpl='$d_frexpl' d_fs_data_s='$d_fs_data_s' d_fseeko='$d_fseeko' d_fsetpos='$d_fsetpos' -d_fstatfs='$d_fstatfs' -d_fstatvfs='$d_fstatvfs' d_fsync='$d_fsync' d_ftello='$d_ftello' d_ftime='$d_ftime' @@ -24207,7 +24099,6 @@ d_gdbmndbm_h_uses_prototypes='$d_gdbmndbm_h_uses_prototypes' d_getaddrinfo='$d_getaddrinfo' d_getcwd='$d_getcwd' d_getespwnam='$d_getespwnam' -d_getfsstat='$d_getfsstat' d_getgrent='$d_getgrent' d_getgrent_r='$d_getgrent_r' d_getgrgid_r='$d_getgrgid_r' @@ -24224,8 +24115,6 @@ d_gethostprotos='$d_gethostprotos' d_getitimer='$d_getitimer' d_getlogin='$d_getlogin' d_getlogin_r='$d_getlogin_r' -d_getmnt='$d_getmnt' -d_getmntent='$d_getmntent' d_getnameinfo='$d_getnameinfo' d_getnbyaddr='$d_getnbyaddr' d_getnbyname='$d_getnbyname' @@ -24266,7 +24155,6 @@ d_gmtime64='$d_gmtime64' d_gmtime_r='$d_gmtime_r' d_gnulibc='$d_gnulibc' d_grpasswd='$d_grpasswd' -d_hasmntopt='$d_hasmntopt' d_htonl='$d_htonl' d_hypot='$d_hypot' d_ilogb='$d_ilogb' @@ -24496,10 +24384,7 @@ d_sresgproto='$d_sresgproto' d_sresuproto='$d_sresuproto' d_stat='$d_stat' d_statblks='$d_statblks' -d_statfs_f_flags='$d_statfs_f_flags' -d_statfs_s='$d_statfs_s' d_static_inline='$d_static_inline' -d_statvfs='$d_statvfs' d_stdio_cnt_lval='$d_stdio_cnt_lval' d_stdio_ptr_lval='$d_stdio_ptr_lval' d_stdio_ptr_lval_nochange_cnt='$d_stdio_ptr_lval_nochange_cnt' @@ -24558,7 +24443,6 @@ d_unordered='$d_unordered' d_unsetenv='$d_unsetenv' d_usleep='$d_usleep' d_usleepproto='$d_usleepproto' -d_ustat='$d_ustat' d_vendorarch='$d_vendorarch' d_vendorbin='$d_vendorbin' d_vendorlib='$d_vendorlib' @@ -24709,7 +24593,6 @@ i_malloc='$i_malloc' i_mallocmalloc='$i_mallocmalloc' i_math='$i_math' i_memory='$i_memory' -i_mntent='$i_mntent' i_ndbm='$i_ndbm' i_netdb='$i_netdb' i_neterrno='$i_neterrno' @@ -24740,7 +24623,6 @@ i_sysioctl='$i_sysioctl' i_syslog='$i_syslog' i_sysmman='$i_sysmman' i_sysmode='$i_sysmode' -i_sysmount='$i_sysmount' i_sysndir='$i_sysndir' i_sysparam='$i_sysparam' i_syspoll='$i_syspoll' @@ -24749,8 +24631,6 @@ i_syssecrt='$i_syssecrt' i_sysselct='$i_sysselct' i_syssockio='$i_syssockio' i_sysstat='$i_sysstat' -i_sysstatfs='$i_sysstatfs' -i_sysstatvfs='$i_sysstatvfs' i_systime='$i_systime' i_systimek='$i_systimek' i_systimes='$i_systimes' @@ -24758,13 +24638,11 @@ i_systypes='$i_systypes' i_sysuio='$i_sysuio' i_sysun='$i_sysun' i_sysutsname='$i_sysutsname' -i_sysvfs='$i_sysvfs' i_syswait='$i_syswait' i_termio='$i_termio' i_termios='$i_termios' i_time='$i_time' i_unistd='$i_unistd' -i_ustat='$i_ustat' i_utime='$i_utime' i_values='$i_values' i_varargs='$i_varargs' diff --git a/Cross/config.sh-arm-linux b/Cross/config.sh-arm-linux index 3b31282..2ac27df 100644 --- a/Cross/config.sh-arm-linux +++ b/Cross/config.sh-arm-linux @@ -32,12 +32,12 @@ alignbytes='4' ansi2knr='' aphostname='/bin/hostname' api_revision='5' -api_subversion='3' +api_subversion='4' api_version='23' -api_versionstring='5.23.3' +api_versionstring='5.23.4' ar='ar' -archlib='/usr/lib/perl5/5.23.3/armv4l-linux' -archlibexp='/usr/lib/perl5/5.23.3/armv4l-linux' +archlib='/usr/lib/perl5/5.23.4/armv4l-linux' +archlibexp='/usr/lib/perl5/5.23.4/armv4l-linux' archname64='' archname='armv4l-linux' archobjs='' @@ -56,7 +56,7 @@ castflags='0' cat='cat' cc='cc' cccdlflags='-fpic' -ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.23.3/armv4l-linux/CORE' +ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.23.4/armv4l-linux/CORE' ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccname='arm-linux-gcc' @@ -222,11 +222,8 @@ d_fpclassl='undef' d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='define' -d_fs_data_s='undef' d_fseeko='define' d_fsetpos='define' -d_fstatfs='define' -d_fstatvfs='define' d_fsync='define' d_ftello='define' d_ftime='undef' @@ -236,7 +233,6 @@ d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' d_getespwnam='undef' -d_getfsstat='undef' d_getgrent='define' d_getgrent_r='undef' d_getgrgid_r='undef' @@ -253,8 +249,6 @@ d_gethostprotos='define' d_getitimer='define' d_getlogin='define' d_getlogin_r='undef' -d_getmnt='undef' -d_getmntent='define' d_getnameinfo='undef' d_getnbyaddr='define' d_getnbyname='define' @@ -295,7 +289,6 @@ d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='define' d_grpasswd='define' -d_hasmntopt='define' d_htonl='define' d_hypot='undef' d_ilogb='undef' @@ -521,10 +514,7 @@ d_sresgproto='undef' d_sresuproto='undef' d_stat='define' d_statblks='define' -d_statfs_f_flags='undef' -d_statfs_s='define' d_static_inline='undef' -d_statvfs='define' d_stdio_cnt_lval='undef' d_stdio_ptr_lval='define' d_stdio_ptr_lval_nochange_cnt='undef' @@ -583,7 +573,6 @@ d_unordered='undef' d_unsetenv='define' d_usleep='define' d_usleepproto='define' -d_ustat='define' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' @@ -730,7 +719,6 @@ i_malloc='define' i_mallocmalloc='undef' i_math='define' i_memory='undef' -i_mntent='define' i_ndbm='undef' i_netdb='define' i_neterrno='undef' @@ -761,7 +749,6 @@ i_sysioctl='define' i_syslog='define' i_sysmman='define' i_sysmode='undef' -i_sysmount='define' i_sysndir='undef' i_sysparam='define' i_syspoll='undef' @@ -770,8 +757,6 @@ i_syssecrt='undef' i_sysselct='define' i_syssockio='undef' i_sysstat='define' -i_sysstatfs='define' -i_sysstatvfs='define' i_systime='define' i_systimek='undef' i_systimes='define' @@ -779,13 +764,11 @@ i_systypes='define' i_sysuio='define' i_sysun='define' i_sysutsname='define' -i_sysvfs='define' i_syswait='define' i_termio='undef' i_termios='define' i_time='define' i_unistd='define' -i_ustat='define' i_utime='define' i_values='define' i_varargs='undef' @@ -796,7 +779,7 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='./install_me_here/usr/lib/perl5/5.23.3/armv4l-linux' +installarchlib='./install_me_here/usr/lib/perl5/5.23.4/armv4l-linux' installbin='./install_me_here/usr/bin' installhtml1dir='' installhtml3dir='' @@ -804,13 +787,13 @@ installman1dir='./install_me_here/usr/share/man/man1' installman3dir='./install_me_here/usr/share/man/man3' installprefix='./install_me_here/usr' installprefixexp='./install_me_here/usr' -installprivlib='./install_me_here/usr/lib/perl5/5.23.3' +installprivlib='./install_me_here/usr/lib/perl5/5.23.4' installscript='./install_me_here/usr/bin' -installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.23.3/armv4l-linux' +installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.23.4/armv4l-linux' installsitebin='./install_me_here/usr/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.23.3' +installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.23.4' installsiteman1dir='./install_me_here/usr/share/man/man1' installsiteman3dir='./install_me_here/usr/share/man/man3' installsitescript='./install_me_here/usr/bin' @@ -944,8 +927,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/usr/lib/perl5/5.23.3' -privlibexp='/usr/lib/perl5/5.23.3' +privlib='/usr/lib/perl5/5.23.4' +privlibexp='/usr/lib/perl5/5.23.4' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -1010,17 +993,17 @@ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 6, 17, 29, 31, 0' sig_size='68' signal_t='void' -sitearch='/usr/lib/perl5/site_perl/5.23.3/armv4l-linux' -sitearchexp='/usr/lib/perl5/site_perl/5.23.3/armv4l-linux' +sitearch='/usr/lib/perl5/site_perl/5.23.4/armv4l-linux' +sitearchexp='/usr/lib/perl5/site_perl/5.23.4/armv4l-linux' sitebin='/usr/bin' sitebinexp='/usr/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/usr/lib/perl5/site_perl/5.23.3' +sitelib='/usr/lib/perl5/site_perl/5.23.4' sitelib_stem='/usr/lib/perl5/site_perl' -sitelibexp='/usr/lib/perl5/site_perl/5.23.3' +sitelibexp='/usr/lib/perl5/site_perl/5.23.4' siteman1dir='/usr/share/man/man1' siteman1direxp='/usr/share/man/man1' siteman3dir='/usr/share/man/man3' @@ -1059,7 +1042,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='3' +subversion='4' sysman='/usr/share/man/man1' tail='' tar='' @@ -1151,8 +1134,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.23.3' -version_patchlevel_string='version 23 subversion 3' +version='5.23.4' +version_patchlevel_string='version 23 subversion 4' versiononly='undef' vi='' xlibpth='/usr/lib/386 /lib/386' @@ -1166,9 +1149,9 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=23 -PERL_SUBVERSION=3 +PERL_SUBVERSION=4 PERL_API_REVISION=5 PERL_API_VERSION=23 -PERL_API_SUBVERSION=3 +PERL_API_SUBVERSION=4 PERL_PATCHLEVEL= PERL_CONFIG_SH=true diff --git a/Cross/config.sh-arm-linux-n770 b/Cross/config.sh-arm-linux-n770 index 6b1aac2..32af6d4 100644 --- a/Cross/config.sh-arm-linux-n770 +++ b/Cross/config.sh-arm-linux-n770 @@ -32,12 +32,12 @@ alignbytes='4' ansi2knr='' aphostname='/bin/hostname' api_revision='5' -api_subversion='3' +api_subversion='4' api_version='23' -api_versionstring='5.23.3' +api_versionstring='5.23.4' ar='ar' -archlib='/usr/lib/perl5/5.23.3/armv4l-linux' -archlibexp='/usr/lib/perl5/5.23.3/armv4l-linux' +archlib='/usr/lib/perl5/5.23.4/armv4l-linux' +archlibexp='/usr/lib/perl5/5.23.4/armv4l-linux' archname64='' archname='armv4l-linux' archobjs='' @@ -55,7 +55,7 @@ castflags='0' cat='cat' cc='arm-none-linux-gnueabi-gcc' cccdlflags='-fpic' -ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.23.3/armv4l-linux/CORE' +ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.23.4/armv4l-linux/CORE' ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccname='arm-linux-gcc' @@ -197,18 +197,14 @@ d_fpclassify='undef' d_fpclassl='undef' d_fpos64_t='undef' d_frexpl='define' -d_fs_data_s='undef' d_fseeko='define' d_fsetpos='define' -d_fstatfs='define' -d_fstatvfs='define' d_fsync='define' d_ftello='define' d_ftime='undef' d_futimes='undef' d_getcwd='define' d_getespwnam='undef' -d_getfsstat='undef' d_getgrent='define' d_getgrent_r='undef' d_getgrgid_r='undef' @@ -225,8 +221,6 @@ d_gethostprotos='define' d_getitimer='define' d_getlogin='define' d_getlogin_r='undef' -d_getmnt='undef' -d_getmntent='define' d_getnbyaddr='define' d_getnbyname='define' d_getnent='define' @@ -265,7 +259,6 @@ d_gettimeod='define' d_gmtime_r='undef' d_gnulibc='define' d_grpasswd='define' -d_hasmntopt='define' d_htonl='define' d_ilogbl='define' d_inc_version_list='define' @@ -441,9 +434,6 @@ d_srandom_r='undef' d_sresgproto='undef' d_sresuproto='undef' d_statblks='define' -d_statfs_f_flags='undef' -d_statfs_s='define' -d_statvfs='define' d_stdio_cnt_lval='undef' d_stdio_ptr_lval='define' d_stdio_ptr_lval_nochange_cnt='undef' @@ -499,7 +489,6 @@ d_unordered='undef' d_unsetenv='define' d_usleep='define' d_usleepproto='define' -d_ustat='define' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' @@ -636,7 +625,6 @@ i_malloc='define' i_mallocmalloc='undef' i_math='define' i_memory='undef' -i_mntent='define' i_ndbm='undef' i_netdb='define' i_neterrno='undef' @@ -664,7 +652,6 @@ i_sysioctl='define' i_syslog='define' i_sysmman='define' i_sysmode='undef' -i_sysmount='define' i_sysndir='undef' i_syspoll='define' i_sysparam='define' @@ -673,8 +660,6 @@ i_syssecrt='undef' i_sysselct='define' i_syssockio='undef' i_sysstat='define' -i_sysstatfs='define' -i_sysstatvfs='define' i_systime='define' i_systimek='undef' i_systimes='define' @@ -682,13 +667,11 @@ i_systypes='define' i_sysuio='define' i_sysun='define' i_sysutsname='define' -i_sysvfs='define' i_syswait='define' i_termio='undef' i_termios='define' i_time='define' i_unistd='define' -i_ustat='define' i_utime='define' i_values='define' i_varargs='undef' @@ -699,7 +682,7 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='./install_me_here/usr/lib/perl5/5.23.3/armv4l-linux' +installarchlib='./install_me_here/usr/lib/perl5/5.23.4/armv4l-linux' installbin='./install_me_here/usr/bin' installhtml1dir='' installhtml3dir='' @@ -707,13 +690,13 @@ installman1dir='./install_me_here/usr/share/man/man1' installman3dir='./install_me_here/usr/share/man/man3' installprefix='./install_me_here/usr' installprefixexp='./install_me_here/usr' -installprivlib='./install_me_here/usr/lib/perl5/5.23.3' +installprivlib='./install_me_here/usr/lib/perl5/5.23.4' installscript='./install_me_here/usr/bin' -installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.23.3/armv4l-linux' +installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.23.4/armv4l-linux' installsitebin='./install_me_here/usr/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.23.3' +installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.23.4' installsiteman1dir='./install_me_here/usr/share/man/man1' installsiteman3dir='./install_me_here/usr/share/man/man3' installsitescript='./install_me_here/usr/bin' @@ -841,8 +824,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/usr/lib/perl5/5.23.3' -privlibexp='/usr/lib/perl5/5.23.3' +privlib='/usr/lib/perl5/5.23.4' +privlibexp='/usr/lib/perl5/5.23.4' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -903,17 +886,17 @@ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 6, 17, 29, 31, 0' sig_size='68' signal_t='void' -sitearch='/usr/lib/perl5/site_perl/5.23.3/armv4l-linux' -sitearchexp='/usr/lib/perl5/site_perl/5.23.3/armv4l-linux' +sitearch='/usr/lib/perl5/site_perl/5.23.4/armv4l-linux' +sitearchexp='/usr/lib/perl5/site_perl/5.23.4/armv4l-linux' sitebin='/usr/bin' sitebinexp='/usr/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/usr/lib/perl5/site_perl/5.23.3' +sitelib='/usr/lib/perl5/site_perl/5.23.4' sitelib_stem='/usr/lib/perl5/site_perl' -sitelibexp='/usr/lib/perl5/site_perl/5.23.3' +sitelibexp='/usr/lib/perl5/site_perl/5.23.4' siteman1dir='/usr/share/man/man1' siteman1direxp='/usr/share/man/man1' siteman3dir='/usr/share/man/man3' @@ -950,7 +933,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='3' +subversion='4' sysman='/usr/share/man/man1' tail='' tar='' @@ -1035,8 +1018,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.23.3' -version_patchlevel_string='version 23 subversion 3' +version='5.23.4' +version_patchlevel_string='version 23 subversion 4' versiononly='undef' vi='' xlibpth='/usr/lib/386 /lib/386' @@ -1050,9 +1033,9 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=23 -PERL_SUBVERSION=3 +PERL_SUBVERSION=4 PERL_API_REVISION=5 PERL_API_VERSION=23 -PERL_API_SUBVERSION=3 +PERL_API_SUBVERSION=4 PERL_PATCHLEVEL= PERL_CONFIG_SH=true diff --git a/INSTALL b/INSTALL index 59a8cae..11c0c9c 100644 --- a/INSTALL +++ b/INSTALL @@ -581,7 +581,7 @@ The directories set up by Configure fall into three broad categories. =item Directories for the perl distribution -By default, Configure will use the following directories for 5.23.3. +By default, Configure will use the following directories for 5.23.4. $version is the full perl version number, including subversion, e.g. 5.12.3, and $archname is a string like sun4-sunos, determined by Configure. The full definitions of all Configure @@ -2440,7 +2440,7 @@ http://www.chiark.greenend.org.uk/~sgtatham/bugs.html =head1 Coexistence with earlier versions of perl 5 -Perl 5.23.3 is not binary compatible with earlier versions of Perl. +Perl 5.23.4 is not binary compatible with earlier versions of Perl. In other words, you will have to recompile your XS modules. In general, you can usually safely upgrade from one version of Perl @@ -2515,9 +2515,9 @@ won't interfere with another version. (The defaults guarantee this for libraries after 5.6.0, but not for executables. TODO?) One convenient way to do this is by using a separate prefix for each version, such as - sh Configure -Dprefix=/opt/perl5.23.3 + sh Configure -Dprefix=/opt/perl5.23.4 -and adding /opt/perl5.23.3/bin to the shell PATH variable. Such users +and adding /opt/perl5.23.4/bin to the shell PATH variable. Such users may also wish to add a symbolic link /usr/local/bin/perl so that scripts can still start with #!/usr/local/bin/perl. @@ -2530,13 +2530,13 @@ seriously consider using a separate directory, since development subversions may not have all the compatibility wrinkles ironed out yet. -=head2 Upgrading from 5.23.2 or earlier +=head2 Upgrading from 5.23.3 or earlier -B Perl modules having binary parts (meaning that a C compiler is used) will have to be recompiled to be -used with 5.23.3. If you find you do need to rebuild an extension with -5.23.3, you may safely do so without disturbing the older +used with 5.23.4. If you find you do need to rebuild an extension with +5.23.4, you may safely do so without disturbing the older installations. (See L<"Coexistence with earlier versions of perl 5"> above.) @@ -2569,15 +2569,15 @@ Firstly, the bare minimum to run this script print("$f\n"); } -in Linux with perl-5.23.3 is as follows (under $Config{prefix}): +in Linux with perl-5.23.4 is as follows (under $Config{prefix}): ./bin/perl - ./lib/perl5/5.23.3/strict.pm - ./lib/perl5/5.23.3/warnings.pm - ./lib/perl5/5.23.3/i686-linux/File/Glob.pm - ./lib/perl5/5.23.3/feature.pm - ./lib/perl5/5.23.3/XSLoader.pm - ./lib/perl5/5.23.3/i686-linux/auto/File/Glob/Glob.so + ./lib/perl5/5.23.4/strict.pm + ./lib/perl5/5.23.4/warnings.pm + ./lib/perl5/5.23.4/i686-linux/File/Glob.pm + ./lib/perl5/5.23.4/feature.pm + ./lib/perl5/5.23.4/XSLoader.pm + ./lib/perl5/5.23.4/i686-linux/auto/File/Glob/Glob.so Secondly, for perl-5.10.1, the Debian perl-base package contains 591 files, (of which 510 are for lib/unicore) totaling about 3.5MB in its diff --git a/MANIFEST b/MANIFEST index 508f31f..716f805 100644 --- a/MANIFEST +++ b/MANIFEST @@ -136,6 +136,35 @@ cpan/AutoLoader/t/01AutoLoader.t See if AutoLoader works cpan/AutoLoader/t/02AutoSplit.t See if AutoSplit works cpan/B-Debug/Debug.pm Compiler Debug backend cpan/B-Debug/t/debug.t See if B::Debug works +cpan/bignum/lib/bigint.pm bigint +cpan/bignum/lib/bignum.pm bignum +cpan/bignum/lib/bigrat.pm bigrat +cpan/bignum/lib/Math/BigFloat/Trace.pm bignum tracing +cpan/bignum/lib/Math/BigInt/Trace.pm bignum tracing +cpan/bignum/t/auth-bigint-hex.t See if bignum works +cpan/bignum/t/auth-bigint-oct.t See if bignum works +cpan/bignum/t/big_e_pi.t See if bignum exports e() and PI() +cpan/bignum/t/bigexp.t See if bignum works +cpan/bignum/t/bigint.t See if bigint works +cpan/bignum/t/bignum.t See if bignum works +cpan/bignum/t/bigrat.t See if bigrat works +cpan/bignum/t/bii_e_pi.t See if bigint exports e() and PI() +cpan/bignum/t/biinfnan.t See if bignum works +cpan/bignum/t/bir_e_pi.t See if bigrat exports e() and PI() +cpan/bignum/t/bninfnan.t See if bignum works +cpan/bignum/t/bn_lite.t See if bignum with Math::BigInt::Lite works +cpan/bignum/t/brinfnan.t See if bignum works +cpan/bignum/t/br_lite.t See if bigrat with Math::BigInt::Lite works +cpan/bignum/t/in_effect.t See if in_effect() works +cpan/bignum/t/infnan.inc See if bignum with inf/NaN works +cpan/bignum/t/option_a.t See if bignum a => X works +cpan/bignum/t/option_l.t See if bignum l => X works +cpan/bignum/t/option_p.t See if bignum p => X works +cpan/bignum/t/overrides.t See if global overrides behave +cpan/bignum/t/ratopt_a.t See if bigrat a => X works +cpan/bignum/t/scope_f.t See if no bignum works +cpan/bignum/t/scope_i.t See if no bigint works +cpan/bignum/t/scope_r.t See if no bigrat works cpan/Compress-Raw-Bzip2/bzip2-src/blocksort.c cpan/Compress-Raw-Bzip2/bzip2-src/bzlib.c cpan/Compress-Raw-Bzip2/bzip2-src/bzlib.h @@ -1147,7 +1176,10 @@ cpan/File-Fetch/lib/File/Fetch.pm File::Fetch cpan/File-Fetch/t/01_File-Fetch.t File::Fetch tests cpan/File-Fetch/t/null_subclass.t cpan/File-Path/lib/File/Path.pm Do things like 'mkdir -p' and 'rm -r' +cpan/File-Path/t/FilePathTest.pm See if File::Path works +cpan/File-Path/t/Path_root.t See if File::Path works cpan/File-Path/t/Path.t See if File::Path works +cpan/File-Path/t/Path_win32.t See if File::Path works cpan/File-Path/t/taint.t See if File::Path works with -T cpan/File-Temp/lib/File/Temp.pm create safe temporary files and file handles cpan/File-Temp/t/cmp.t See if File::Temp works @@ -1625,6 +1657,8 @@ cpan/Math-BigInt/t/bigints.t See if BigInt.pm works cpan/Math-BigInt/t/biglog.t Test the log function cpan/Math-BigInt/t/big_pi_e.t test bpi() and bexp() cpan/Math-BigInt/t/bigroot.t Test the broot function +cpan/Math-BigInt/t/blog-mbf.t Math::BigInt tests +cpan/Math-BigInt/t/blog-mbi.t Math::BigInt tests cpan/Math-BigInt/t/calling.t Test calling conventions cpan/Math-BigInt/t/config.t Test Math::BigInt->config() cpan/Math-BigInt/t/constant.t Test Math::BigInt/BigFloat under :constant @@ -1645,6 +1679,8 @@ cpan/Math-BigInt/t/mbimbf.t BigInt/BigFloat accuracy, precision and fallback, r cpan/Math-BigInt/t/mbi_rand.t Test Math::BigInt randomly cpan/Math-BigInt/t/nan_cmp.t overloaded comparison involving *NaN* cpan/Math-BigInt/t/new_overloaded.t test overloaded numbers in BigFloat's new() +cpan/Math-BigInt/t/objectify_mbf.t Math::BigInt tests +cpan/Math-BigInt/t/objectify_mbi.t Math::BigInt tests cpan/Math-BigInt/t/req_mbf0.t test: require Math::BigFloat; ->bzero(); cpan/Math-BigInt/t/req_mbf1.t test: require Math::BigFloat; ->bone(); cpan/Math-BigInt/t/req_mbfa.t test: require Math::BigFloat; ->bnan(); @@ -1756,9 +1792,12 @@ cpan/Module-Metadata/lib/Module/Metadata.pm cpan/Module-Metadata/t/contains_pod.t cpan/Module-Metadata/t/encoding.t cpan/Module-Metadata/t/endpod.t +cpan/Module-Metadata/t/extract-package.t +cpan/Module-Metadata/t/extract-version.t cpan/Module-Metadata/t/lib/0_1/Foo.pm cpan/Module-Metadata/t/lib/0_2/Foo.pm cpan/Module-Metadata/t/lib/ENDPOD.pm +cpan/Module-Metadata/t/lib/GeneratePackage.pm cpan/Module-Metadata/t/metadata.t cpan/Module-Metadata/t/taint.t cpan/Module-Metadata/t/version.t @@ -2990,33 +3029,6 @@ dist/base/t/lib/HasSigDie.pm Module for testing base.pm dist/base/t/sigdie.t See if base works with SIGDIE dist/base/t/version.t See if base works with versions dist/base/t/warnings.t See if base works with warnings -dist/bignum/lib/bigint.pm bigint -dist/bignum/lib/bignum.pm bignum -dist/bignum/lib/bigrat.pm bigrat -dist/bignum/lib/Math/BigFloat/Trace.pm bignum tracing -dist/bignum/lib/Math/BigInt/Trace.pm bignum tracing -dist/bignum/t/big_e_pi.t See if bignum exports e() and PI() -dist/bignum/t/bigexp.t See if bignum works -dist/bignum/t/bigint.t See if bigint works -dist/bignum/t/bignum.t See if bignum works -dist/bignum/t/bigrat.t See if bigrat works -dist/bignum/t/bii_e_pi.t See if bigint exports e() and PI() -dist/bignum/t/biinfnan.t See if bignum works -dist/bignum/t/bir_e_pi.t See if bigrat exports e() and PI() -dist/bignum/t/bninfnan.t See if bignum works -dist/bignum/t/bn_lite.t See if bignum with Math::BigInt::Lite works -dist/bignum/t/brinfnan.t See if bignum works -dist/bignum/t/br_lite.t See if bigrat with Math::BigInt::Lite works -dist/bignum/t/in_effect.t See if in_effect() works -dist/bignum/t/infnan.inc See if bignum with inf/NaN works -dist/bignum/t/option_a.t See if bignum a => X works -dist/bignum/t/option_l.t See if bignum l => X works -dist/bignum/t/option_p.t See if bignum p => X works -dist/bignum/t/overrides.t See if global overrides behave -dist/bignum/t/ratopt_a.t See if bigrat a => X works -dist/bignum/t/scope_f.t See if no bignum works -dist/bignum/t/scope_i.t See if no bigint works -dist/bignum/t/scope_r.t See if no bigrat works dist/Carp/lib/Carp/Heavy.pm Error message retired workhorse dist/Carp/lib/Carp.pm Error message extension dist/Carp/Makefile.PL makefile writer for Carp @@ -3192,6 +3204,7 @@ dist/I18N-LangTags/t/20_locales.t See whether I18N::LangTags works dist/I18N-LangTags/t/50_super.t See whether I18N::LangTags works dist/I18N-LangTags/t/55_supers_strict.t See whether I18N::LangTags works dist/I18N-LangTags/t/80_all_env.t See whether I18N::LangTags works +dist/if/Changes if perl module change log dist/if/if.pm For "use if" dist/if/t/if.t Tests for "use if" dist/IO/ChangeLog IO perl module change log @@ -3749,6 +3762,7 @@ ext/PerlIO-encoding/encoding.xs PerlIO::encoding ext/PerlIO-encoding/t/encoding.t See if PerlIO encoding conversion works ext/PerlIO-encoding/t/fallback.t See if PerlIO fallbacks work ext/PerlIO-encoding/t/nolooping.t Tests for PerlIO::encoding +ext/PerlIO-encoding/t/threads.t Tests PerlIO::encoding and threads ext/PerlIO-mmap/mmap.pm PerlIO layer for memory maps ext/PerlIO-mmap/mmap.xs PerlIO layer for memory maps ext/PerlIO-scalar/scalar.pm PerlIO layer for scalars @@ -3930,6 +3944,7 @@ ext/XS-APItest/t/customop.t XS::APItest: tests for custom ops ext/XS-APItest/t/cv_name.t test cv_name ext/XS-APItest/t/eval-filter.t Simple source filter/eval test ext/XS-APItest/t/exception.t XS::APItest extension +ext/XS-APItest/t/extend.t test EXTEND() macro ext/XS-APItest/t/fetch_pad_names.t Tests for UTF8 names in pad ext/XS-APItest/t/gotosub.t XS::APItest: tests goto &xsub and hints ext/XS-APItest/t/grok.t XS::APItest: tests for grok* functions @@ -4607,6 +4622,7 @@ pod/perl5220delta.pod Perl changes in version 5.22.0 pod/perl5230delta.pod Perl changes in version 5.23.0 pod/perl5231delta.pod Perl changes in version 5.23.1 pod/perl5232delta.pod Perl changes in version 5.23.2 +pod/perl5233delta.pod Perl changes in version 5.23.3 pod/perl561delta.pod Perl changes in version 5.6.1 pod/perl56delta.pod Perl changes in version 5.6 pod/perl581delta.pod Perl changes in version 5.8.1 @@ -4723,6 +4739,7 @@ Porting/bump-perl-version bump the perl version in relevant files Porting/check83.pl Check whether we are 8.3-friendly Porting/checkansi.pl Check source code for ANSI-C violations Porting/checkAUTHORS.pl Check that the AUTHORS file is complete +Porting/checkcfguse.pl Check that config symbols are being used Porting/checkcfgvar.pl Check that config scripts define all symbols Porting/check-cpan-pollution Check for commits that may wrongly touch CPAN distros Porting/checkpodencoding.pl Check POD encoding diff --git a/META.json b/META.json index 4381957..5cdab4b 100644 --- a/META.json +++ b/META.json @@ -18,7 +18,6 @@ "dist/Attribute-Handlers", "dist/autouse", "dist/base", - "dist/bignum", "dist/Carp", "dist/constant", "dist/Data-Dumper", @@ -123,6 +122,6 @@ "url" : "http://perl5.git.perl.org/" } }, - "version" : "5.023003", + "version" : "5.023004", "x_serialization_backend" : "JSON::PP version 2.27300" } diff --git a/META.yml b/META.yml index 5863973..2d745e9 100644 --- a/META.yml +++ b/META.yml @@ -16,7 +16,6 @@ no_index: - dist/Attribute-Handlers - dist/autouse - dist/base - - dist/bignum - dist/Carp - dist/constant - dist/Data-Dumper @@ -110,5 +109,5 @@ resources: homepage: http://www.perl.org/ license: http://dev.perl.org/licenses/ repository: http://perl5.git.perl.org/ -version: '5.023003' +version: '5.023004' x_serialization_backend: 'CPAN::Meta::YAML version 0.017' diff --git a/Makefile.SH b/Makefile.SH index ad220bf..14ab983 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -504,7 +504,7 @@ mini_obj = $(minindt_obj) $(MINIDTRACE_O) ndt_obj = $(obj0) $(obj1) $(obj2) $(obj3) $(ARCHOBJS) obj = $(ndt_obj) $(DTRACE_O) -perltoc_pod_prereqs = extra.pods pod/perl5233delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod +perltoc_pod_prereqs = extra.pods pod/perl5234delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod generated_pods = pod/perltoc.pod $(perltoc_pod_prereqs) generated_headers = uudmap.h bitcount.h mg_data.h @@ -1064,9 +1064,9 @@ pod/perlintern.pod: $(MINIPERL_EXE) autodoc.pl embed.fnc pod/perlmodlib.pod: $(MINIPERL_EXE) pod/perlmodlib.PL MANIFEST $(MINIPERL) pod/perlmodlib.PL -q -pod/perl5233delta.pod: pod/perldelta.pod - $(RMS) pod/perl5233delta.pod - $(LNS) perldelta.pod pod/perl5233delta.pod +pod/perl5234delta.pod: pod/perldelta.pod + $(RMS) pod/perl5234delta.pod + $(LNS) perldelta.pod pod/perl5234delta.pod extra.pods: $(MINIPERL_EXE) -@test ! -f extra.pods || rm -f `cat extra.pods` @@ -1638,6 +1638,9 @@ distcheck: FORCE .PHONY: ctags +TAGS: $(c1) $(c2) $(c3) $(c4) $(c5) $(h) + etags $(c1) $(c2) $(c3) $(c4) $(c5) $(h) + ctags: ctags -f Tags -N --totals --languages=c --langmap=c:+.h --exclude=opmini.c --exclude=perlmini.c *.c *.h diff --git a/NetWare/Makefile b/NetWare/Makefile index 6873b38..443b03b 100644 --- a/NetWare/Makefile +++ b/NetWare/Makefile @@ -86,7 +86,7 @@ NLM_VERSION = 3,20,0 # Here comes the CW tools - TO BE FILLED TO BUILD WITH CW - -MODULE_DESC = "Perl 5.23.3 for NetWare" +MODULE_DESC = "Perl 5.23.4 for NetWare" CCTYPE = CodeWarrior C_COMPILER = mwccnlm -c CPP_COMPILER = mwccnlm @@ -462,7 +462,7 @@ INST_NW_TOP2 = $(INST_NW_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -INST_VER = \5.23.3 +INST_VER = \5.23.4 # # Comment this out if you DON'T want your perl installation to have diff --git a/NetWare/config.wc b/NetWare/config.wc index e70b4df..7e80150 100644 --- a/NetWare/config.wc +++ b/NetWare/config.wc @@ -210,11 +210,8 @@ d_fpclassl='undef' d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' -d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='define' -d_fstatfs='undef' -d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='define' @@ -224,7 +221,6 @@ d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' d_getespwnam='undef' -d_getfsstat='undef' d_getgrent='undef' d_getgrent_r='undef' d_getgrgid_r='undef' @@ -241,8 +237,6 @@ d_gethostprotos='define' d_getitimer='undef' d_getlogin='define' d_getlogin_r='undef' -d_getmnt='undef' -d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' @@ -284,7 +278,6 @@ d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' -d_hasmntopt='undef' d_htonl='define' d_hypot='undef' d_ilogb='undef' @@ -511,10 +504,7 @@ d_sresgproto='undef' d_sresuproto='undef' d_stat='define' d_statblks='undef' -d_statfs_f_flags='undef' -d_statfs_s='undef' d_static_inline='undef' -d_statvfs='undef' d_stdio_cnt_lval='undef' d_stdio_ptr_lval='undef' d_stdio_ptr_lval_nochange_cnt='undef' @@ -573,7 +563,6 @@ d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' -d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' @@ -712,7 +701,6 @@ i_malloc='define' i_mallocmalloc='undef' i_math='define' i_memory='undef' -i_mntent='undef' i_ndbm='undef' i_netdb='define' i_neterrno='undef' @@ -743,7 +731,6 @@ i_sysioctl='define' i_syslog='undef' i_sysmman='undef' i_sysmode='undef' -i_sysmount='undef' i_sysndir='undef' i_sysparam='undef' i_syspoll='undef' @@ -752,8 +739,6 @@ i_syssecrt='undef' i_sysselct='undef' i_syssockio='define' i_sysstat='define' -i_sysstatfs='undef' -i_sysstatvfs='undef' i_systime='undef' i_systimek='undef' i_systimes='undef' @@ -761,13 +746,11 @@ i_systypes='define' i_sysuio='undef' i_sysun='undef' i_sysutsname='define' -i_sysvfs='undef' i_syswait='undef' i_termio='undef' i_termios='undef' i_time='define' i_unistd='undef' -i_ustat='undef' i_utime='define' i_values='undef' i_varargs='undef' diff --git a/NetWare/config_H.wc b/NetWare/config_H.wc index 186f7a8..f96c667 100644 --- a/NetWare/config_H.wc +++ b/NetWare/config_H.wc @@ -1042,7 +1042,7 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl\\5.23.3\\lib\\NetWare-x86-multi-thread" /**/ +#define ARCHLIB "c:\\perl\\5.23.4\\lib\\NetWare-x86-multi-thread" /**/ /*#define ARCHLIB_EXP "" /**/ /* ARCHNAME: @@ -1073,8 +1073,8 @@ * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "c:\\perl\\5.23.3\\bin\\NetWare-x86-multi-thread" /**/ -#define BIN_EXP "c:\\perl\\5.23.3\\bin\\NetWare-x86-multi-thread" /**/ +#define BIN "c:\\perl\\5.23.4\\bin\\NetWare-x86-multi-thread" /**/ +#define BIN_EXP "c:\\perl\\5.23.4\\bin\\NetWare-x86-multi-thread" /**/ /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, @@ -1313,24 +1313,12 @@ */ /*#define HAS_FREXPL /**/ -/* HAS_STRUCT_FS_DATA: - * This symbol, if defined, indicates that the struct fs_data - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_FS_DATA /**/ - /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO /**/ -/* HAS_FSTATFS: - * This symbol, if defined, indicates that the fstatfs routine is - * available to stat filesystems by file descriptors. - */ -/*#define HAS_FSTATFS /**/ - /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to @@ -1373,12 +1361,6 @@ */ /*#define HAS_GETESPWNAM /**/ -/* HAS_GETFSSTAT: - * This symbol, if defined, indicates that the getfsstat routine is - * available to stat filesystems in bulk. - */ -/*#define HAS_GETFSSTAT /**/ - /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. @@ -1446,18 +1428,6 @@ */ /*#define HAS_GETITIMER /**/ -/* HAS_GETMNT: - * This symbol, if defined, indicates that the getmnt routine is - * available to get filesystem mount info by filename. - */ -/*#define HAS_GETMNT /**/ - -/* HAS_GETMNTENT: - * This symbol, if defined, indicates that the getmntent routine is - * available to iterate through mounted file systems to get their info. - */ -/*#define HAS_GETMNTENT /**/ - /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. @@ -1580,11 +1550,6 @@ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif -/* HAS_HASMNTOPT: - * This symbol, if defined, indicates that the hasmntopt routine is - * available to query the mount options of file systems. - */ -/*#define HAS_HASMNTOPT /**/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and @@ -1741,15 +1706,7 @@ * available to split a long double x into a fractional part f and * an integer part i such that |f| < 1.0 and (f + i) = x. */ -/* HAS_MODFL_POW32_BUG: - * This symbol, if defined, indicates that the modfl routine is - * broken for long doubles >= pow(2, 32). - * For example from 4294967303.150000 one would get 4294967302.000000 - * and 1.150000. The bug has been seen in certain versions of glibc, - * release 2.2.2 is known to be okay. - */ /*#define HAS_MODFL /**/ -/*#define HAS_MODFL_POW32_BUG /**/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is @@ -2025,44 +1982,8 @@ * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ -/* HAS_MSG_CTRUNC: - * This symbol, if defined, indicates that the MSG_CTRUNC is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_DONTROUTE: - * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_OOB: - * This symbol, if defined, indicates that the MSG_OOB is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PEEK: - * This symbol, if defined, indicates that the MSG_PEEK is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PROXY: - * This symbol, if defined, indicates that the MSG_PROXY is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_SCM_RIGHTS: - * This symbol, if defined, indicates that the SCM_RIGHTS is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ #define HAS_SOCKET /**/ /*#define HAS_SOCKETPAIR /**/ -/*#define HAS_MSG_CTRUNC /**/ -/*#define HAS_MSG_DONTROUTE /**/ -/*#define HAS_MSG_OOB /**/ -/*#define HAS_MSG_PEEK /**/ -/*#define HAS_MSG_PROXY /**/ -/*#define HAS_SCM_RIGHTS /**/ /* HAS_SOCKS5_INIT: * This symbol, if defined, indicates that the socks5_init routine is @@ -2084,29 +2005,6 @@ /*#define USE_STAT_BLOCKS /**/ #endif -/* HAS_STRUCT_STATFS_F_FLAGS: - * This symbol, if defined, indicates that the struct statfs - * does have the f_flags member containing the mount flags of - * the filesystem containing the file. - * This kind of struct statfs is coming from (BSD 4.3), - * not from (SYSV). Older BSDs (like Ultrix) do not - * have statfs() and struct statfs, they have ustat() and getmnt() - * with struct ustat and struct fs_data. - */ -/*#define HAS_STRUCT_STATFS_F_FLAGS /**/ - -/* HAS_STRUCT_STATFS: - * This symbol, if defined, indicates that the struct statfs - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_STATFS /**/ - -/* HAS_FSTATVFS: - * This symbol, if defined, indicates that the fstatvfs routine is - * available to stat filesystems by file descriptors. - */ -/*#define HAS_FSTATVFS /**/ - /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) * of the stdio FILE structure can be used to access the stdio buffer @@ -2282,12 +2180,6 @@ /*#define USE_SEMCTL_SEMUN /**/ /*#define USE_SEMCTL_SEMID_DS /**/ -/* HAS_USTAT: - * This symbol, if defined, indicates that the ustat system call is - * available to query file system statistics by dev_t. - */ -/*#define HAS_USTAT /**/ - /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ @@ -2503,12 +2395,6 @@ */ /*#define I_MACH_CTHREADS /**/ -/* I_MNTENT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_MNTENT /**/ - /* I_NETDB: * This symbol, if defined, indicates that exists and * should be included. @@ -2615,23 +2501,6 @@ */ /*#define I_SYSMODE /**/ -/* I_SYS_MOUNT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_MOUNT /**/ - -/* I_SYS_STATFS: - * This symbol, if defined, indicates that exists. - */ -/*#define I_SYS_STATFS /**/ - -/* I_SYS_STATVFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_STATVFS /**/ - /* I_SYSUIO: * This symbol, if defined, indicates that exists and * should be included. @@ -2644,12 +2513,6 @@ */ #define I_SYSUTSNAME /**/ -/* I_SYS_VFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_VFS /**/ - /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . @@ -2666,12 +2529,6 @@ /*#define I_SYS_TIME /**/ /*#define I_SYS_TIME_KERNEL /**/ -/* I_USTAT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_USTAT /**/ - /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over * which perl.c:incpush() and lib/lib.pm will automatically @@ -3091,7 +2948,7 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "c:\\perl\\site\\5.23.3\\lib\\NetWare-x86-multi-thread" /**/ +#define SITEARCH "c:\\perl\\site\\5.23.4\\lib\\NetWare-x86-multi-thread" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -3114,7 +2971,7 @@ * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ -#define SITELIB "c:\\perl\\site\\5.23.3\\lib" /**/ +#define SITELIB "c:\\perl\\site\\5.23.4\\lib" /**/ /*#define SITELIB_EXP "" /**/ #define SITELIB_STEM "" /**/ diff --git a/Porting/Glossary b/Porting/Glossary index 2cd4bb3..ae8cc79 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -932,10 +932,6 @@ d_frexpl (d_frexpl.U): This variable conditionally defines the HAS_FREXPL symbol, which indicates to the C program that the frexpl() routine is available. -d_fs_data_s (d_fs_data_s.U): - This variable conditionally defines the HAS_STRUCT_FS_DATA symbol, - which indicates that the struct fs_data is supported. - d_fseeko (d_fseeko.U): This variable conditionally defines the HAS_FSEEKO symbol, which indicates to the C program that the fseeko() routine is available. @@ -944,14 +940,6 @@ d_fsetpos (d_fsetpos.U): This variable conditionally defines HAS_FSETPOS if fsetpos() is available to set the file position indicator. -d_fstatfs (d_fstatfs.U): - This variable conditionally defines the HAS_FSTATFS symbol, which - indicates to the C program that the fstatfs() routine is available. - -d_fstatvfs (d_statvfs.U): - This variable conditionally defines the HAS_FSTATVFS symbol, which - indicates to the C program that the fstatvfs() routine is available. - d_fsync (d_fsync.U): This variable conditionally defines the HAS_FSYNC symbol, which indicates to the C program that the fsync() routine is available. @@ -1022,10 +1010,6 @@ d_getespwnam (d_getespwnam.U): This variable conditionally defines HAS_GETESPWNAM if getespwnam() is available to retrieve enhanced (shadow) password entries by name. -d_getfsstat (d_getfsstat.U): - This variable conditionally defines the HAS_GETFSSTAT symbol, which - indicates to the C program that the getfsstat() routine is available. - d_getgrent (d_getgrent.U): This variable conditionally defines the HAS_GETGRENT symbol, which indicates to the C program that the getgrent() routine is available @@ -1105,16 +1089,6 @@ d_getlogin_r (d_getlogin_r.U): which indicates to the C program that the getlogin_r() routine is available. -d_getmnt (d_getmnt.U): - This variable conditionally defines the HAS_GETMNT symbol, which - indicates to the C program that the getmnt() routine is available - to retrieve one or more mount info blocks by filename. - -d_getmntent (d_getmntent.U): - This variable conditionally defines the HAS_GETMNTENT symbol, which - indicates to the C program that the getmntent() routine is available - to iterate through mounted files to get their mount info. - d_getnameinfo (d_getnameinfo.U): This variable conditionally defines the HAS_GETNAMEINFO symbol, which indicates to the C program that the getnameinfo() function @@ -1310,11 +1284,6 @@ d_grpasswd (i_grp.U): This variable conditionally defines GRPASSWD, which indicates that struct group in contains gr_passwd. -d_hasmntopt (d_hasmntopt.U): - This variable conditionally defines the HAS_HASMNTOPT symbol, which - indicates to the C program that the hasmntopt() routine is available - to query the mount options of file systems. - d_htonl (d_htonl.U): This variable conditionally defines HAS_HTONL if htonl() and its friends are available to do network order byte swapping. @@ -1660,13 +1629,6 @@ d_modfl (d_modfl.U): This variable conditionally defines the HAS_MODFL symbol, which indicates to the C program that the modfl() routine is available. -d_modfl_pow32_bug (d_modfl.U): - This variable conditionally defines the HAS_MODFL_POW32_BUG symbol, - which indicates that modfl() is broken for long doubles >= pow(2, 32). - For example from 4294967303.150000 one would get 4294967302.000000 - and 1.150000. The bug has been seen in certain versions of glibc, - release 2.2.2 is known to be okay. - d_modflproto (d_modfl.U): This symbol, if defined, indicates that the system provides a prototype for the modfl() function. Otherwise, it is up @@ -1681,31 +1643,6 @@ d_msg (d_msg.U): This variable conditionally defines the HAS_MSG symbol, which indicates that the entire msg*(2) library is present. -d_msg_ctrunc (d_socket.U): - This variable conditionally defines the HAS_MSG_CTRUNC symbol, - which indicates that the MSG_CTRUNC is available. #ifdef is - not enough because it may be an enum, glibc has been known to do this. - -d_msg_dontroute (d_socket.U): - This variable conditionally defines the HAS_MSG_DONTROUTE symbol, - which indicates that the MSG_DONTROUTE is available. #ifdef is - not enough because it may be an enum, glibc has been known to do this. - -d_msg_oob (d_socket.U): - This variable conditionally defines the HAS_MSG_OOB symbol, - which indicates that the MSG_OOB is available. #ifdef is - not enough because it may be an enum, glibc has been known to do this. - -d_msg_peek (d_socket.U): - This variable conditionally defines the HAS_MSG_PEEK symbol, - which indicates that the MSG_PEEK is available. #ifdef is - not enough because it may be an enum, glibc has been known to do this. - -d_msg_proxy (d_socket.U): - This variable conditionally defines the HAS_MSG_PROXY symbol, - which indicates that the MSG_PROXY is available. #ifdef is - not enough because it may be an enum, glibc has been known to do this. - d_msgctl (d_msgctl.U): This variable conditionally defines the HAS_MSGCTL symbol, which indicates to the C program that the msgctl() routine is available. @@ -2099,11 +2036,6 @@ d_sched_yield (d_pthread_y.U): symbol if the sched_yield routine is available to yield the execution of the current thread. -d_scm_rights (d_socket.U): - This variable conditionally defines the HAS_SCM_RIGHTS symbol, - which indicates that the SCM_RIGHTS is available. #ifdef is - not enough because it may be an enum, glibc has been known to do this. - d_SCNfldbl (longdblfio.U): This variable conditionally defines the PERL_PRIfldbl symbol, which indicates that stdio has a symbol to scan long doubles. @@ -2430,26 +2362,12 @@ d_statblks (d_statblks.U): if this system has a stat structure declaring st_blksize and st_blocks. -d_statfs_f_flags (d_statfs_f_flags.U): - This variable conditionally defines the HAS_STRUCT_STATFS_F_FLAGS - symbol, which indicates to struct statfs from has f_flags member. - This kind of struct statfs is coming from sys/mount.h (BSD), - not from sys/statfs.h (SYSV). - -d_statfs_s (d_statfs_s.U): - This variable conditionally defines the HAS_STRUCT_STATFS symbol, - which indicates that the struct statfs is supported. - d_static_inline (d_static_inline.U): This variable conditionally defines the HAS_STATIC_INLINE symbol, which indicates that the C compiler supports C99-style static inline. That is, the function can't be called from another translation unit. -d_statvfs (d_statvfs.U): - This variable conditionally defines the HAS_STATVFS symbol, which - indicates to the C program that the statvfs() routine is available. - d_stdio_cnt_lval (d_stdstdio.U): This variable conditionally defines STDIO_CNT_LVALUE if the FILE_cnt macro can be used as an lvalue. @@ -2712,10 +2630,6 @@ d_usleepproto (d_usleepproto.U): a prototype for the usleep() function. Otherwise, it is up to the program to supply one. -d_ustat (d_ustat.U): - This variable conditionally defines HAS_USTAT if ustat() is - available to query file system statistics by dev_t. - d_vendorarch (vendorarch.U): This variable conditionally defined PERL_VENDORARCH. @@ -3447,10 +3361,6 @@ i_memory (i_memory.U): This variable conditionally defines the I_MEMORY symbol, and indicates whether a C program should include . -i_mntent (i_mntent.U): - This variable conditionally defines the I_MNTENT symbol, and indicates - whether a C program should include . - i_ndbm (i_ndbm.U): This variable conditionally defines the I_NDBM symbol, which indicates to the C program that exists and should @@ -3584,10 +3494,6 @@ i_sysmode (i_sysmode.U): This variable conditionally defines the I_SYSMODE symbol, and indicates whether a C program should include . -i_sysmount (i_sysmount.U): - This variable conditionally defines the I_SYSMOUNT symbol, - and indicates whether a C program should include . - i_sysndir (i_sysndir.U): This variable conditionally defines the I_SYS_NDIR symbol, and indicates whether a C program should include . @@ -3622,14 +3528,6 @@ i_sysstat (i_sysstat.U): This variable conditionally defines the I_SYS_STAT symbol, and indicates whether a C program should include . -i_sysstatfs (i_sysstatfs.U): - This variable conditionally defines the I_SYSSTATFS symbol, - and indicates whether a C program should include . - -i_sysstatvfs (i_sysstatvfs.U): - This variable conditionally defines the I_SYSSTATVFS symbol, - and indicates whether a C program should include . - i_systime (i_time.U): This variable conditionally defines I_SYS_TIME, which indicates to the C program that it should include . @@ -3660,10 +3558,6 @@ i_sysutsname (i_sysutsname.U): This variable conditionally defines the I_SYSUTSNAME symbol, and indicates whether a C program should include . -i_sysvfs (i_sysvfs.U): - This variable conditionally defines the I_SYSVFS symbol, - and indicates whether a C program should include . - i_syswait (i_syswait.U): This variable conditionally defines I_SYS_WAIT, which indicates to the C program that it should include . @@ -3686,10 +3580,6 @@ i_unistd (i_unistd.U): This variable conditionally defines the I_UNISTD symbol, and indicates whether a C program should include . -i_ustat (i_ustat.U): - This variable conditionally defines the I_USTAT symbol, and indicates - whether a C program should include . - i_utime (i_utime.U): This variable conditionally defines the I_UTIME symbol, and indicates whether a C program should include . diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index ce207c4..64fb410 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -184,12 +184,14 @@ use File::Glob qw(:case); }, 'bignum' => { - 'DISTRIBUTION' => 'PJACKLAM/bignum-0.37.tar.gz', - 'FILES' => q[dist/bignum], + 'DISTRIBUTION' => 'PJACKLAM/bignum-0.41.tar.gz', + 'FILES' => q[cpan/bignum], 'EXCLUDED' => [ qr{^inc/Module/}, - qw( t/pod.t - t/pod_cov.t + qw( t/00sig.t + t/01load.t + t/02pod.t + t/03podcov.t ), ], }, @@ -200,16 +202,18 @@ use File::Glob qw(:case); }, 'Compress::Raw::Bzip2' => { - 'DISTRIBUTION' => 'PMQS/Compress-Raw-Bzip2-2.068.tar.gz', + 'DISTRIBUTION' => 'PMQS/Compress-Raw-Bzip2-2.069.tar.gz', 'FILES' => q[cpan/Compress-Raw-Bzip2], 'EXCLUDED' => [ qr{^t/Test/}, + 'bzip2-src/bzip2-const.patch', 'bzip2-src/bzip2-cpp.patch', + 'bzip2-src/bzip2-unsigned.patch', ], }, 'Compress::Raw::Zlib' => { - 'DISTRIBUTION' => 'PMQS/Compress-Raw-Zlib-2.068.tar.gz', + 'DISTRIBUTION' => 'PMQS/Compress-Raw-Zlib-2.069.tar.gz', 'FILES' => q[cpan/Compress-Raw-Zlib], 'EXCLUDED' => [ @@ -219,9 +223,6 @@ use File::Glob qw(:case); t/99pod.t ), ], - - # https://rt.cpan.org/Ticket/Display.html?id=106799 - 'CUSTOMIZED' => [ qw[ Zlib.xs ] ], }, 'Config::Perl::V' => { @@ -340,7 +341,7 @@ use File::Glob qw(:case); }, 'Devel::PPPort' => { - 'DISTRIBUTION' => 'WOLFSAGE/Devel-PPPort-3.31.tar.gz', + 'DISTRIBUTION' => 'WOLFSAGE/Devel-PPPort-3.32.tar.gz', # RJBS has asked MHX to have UPSTREAM be 'blead' # (i.e. move this from cpan/ to dist/) 'FILES' => q[cpan/Devel-PPPort], @@ -385,8 +386,14 @@ use File::Glob qw(:case); }, 'Encode' => { - 'DISTRIBUTION' => 'DANKOGAI/Encode-2.77.tar.gz', + 'DISTRIBUTION' => 'DANKOGAI/Encode-2.78.tar.gz', 'FILES' => q[cpan/Encode], + CUSTOMIZED => [ + qw( Encode.xs + Unicode/Unicode.xs + encoding.pm + ), + ], }, 'encoding::warnings' => { @@ -405,12 +412,9 @@ use File::Glob qw(:case); }, 'experimental' => { - 'DISTRIBUTION' => 'LEONT/experimental-0.014.tar.gz', + 'DISTRIBUTION' => 'LEONT/experimental-0.016.tar.gz', 'FILES' => q[cpan/experimental], - 'EXCLUDED' => [ - qr{^t/release-.*\.t}, - 't/00-compile.t', - ], + 'EXCLUDED' => [qr{^xt/}], }, 'Exporter' => { @@ -424,7 +428,7 @@ use File::Glob qw(:case); }, 'ExtUtils::CBuilder' => { - 'DISTRIBUTION' => 'AMBS/ExtUtils-CBuilder-0.280223.tar.gz', + 'DISTRIBUTION' => 'AMBS/ExtUtils-CBuilder-0.280224.tar.gz', 'FILES' => q[dist/ExtUtils-CBuilder], 'EXCLUDED' => [ qw(README.mkdn), @@ -503,12 +507,11 @@ use File::Glob qw(:case); }, 'File::Path' => { - 'DISTRIBUTION' => 'RICHE/File-Path-2.11.tar.gz', + 'DISTRIBUTION' => 'RICHE/File-Path-2.12.tar.gz', 'FILES' => q[cpan/File-Path], 'EXCLUDED' => [ - qw( eg/setup-extra-tests - t/Path-Class.t - ) + qw(t/Path-Class.t), + qr{^xt/}, ], }, @@ -605,7 +608,7 @@ use File::Glob qw(:case); }, 'if' => { - 'DISTRIBUTION' => 'ILYAZ/modules/if-0.0601.tar.gz', + 'DISTRIBUTION' => 'RJBS/if-0.0606.tar.gz', 'FILES' => q[dist/if], }, @@ -616,7 +619,7 @@ use File::Glob qw(:case); }, 'IO-Compress' => { - 'DISTRIBUTION' => 'PMQS/IO-Compress-2.068.tar.gz', + 'DISTRIBUTION' => 'PMQS/IO-Compress-2.069.tar.gz', 'FILES' => q[cpan/IO-Compress], 'EXCLUDED' => [ qr{^examples/}, @@ -718,7 +721,7 @@ use File::Glob qw(:case); }, 'Math::BigInt' => { - 'DISTRIBUTION' => 'PJACKLAM/Math-BigInt-1.9997.tar.gz', + 'DISTRIBUTION' => 'PJACKLAM/Math-BigInt-1.999704.tar.gz', 'FILES' => q[cpan/Math-BigInt], 'EXCLUDED' => [ qr{^inc/}, @@ -732,7 +735,7 @@ use File::Glob qw(:case); }, 'Math::BigInt::FastCalc' => { - 'DISTRIBUTION' => 'PJACKLAM/Math-BigInt-FastCalc-0.31.tar.gz', + 'DISTRIBUTION' => 'PJACKLAM/Math-BigInt-FastCalc-0.34.tar.gz', 'FILES' => q[cpan/Math-BigInt-FastCalc], 'EXCLUDED' => [ qr{^inc/}, @@ -755,7 +758,7 @@ use File::Glob qw(:case); }, 'Math::BigRat' => { - 'DISTRIBUTION' => 'PJACKLAM/Math-BigRat-0.2606.tar.gz', + 'DISTRIBUTION' => 'PJACKLAM/Math-BigRat-0.260801.tar.gz', 'FILES' => q[cpan/Math-BigRat], 'EXCLUDED' => [ qr{^inc/}, @@ -765,6 +768,10 @@ use File::Glob qw(:case); t/03podcov.t ), ], + 'CUSTOMIZED' => [ + qw( lib/Math/BigRat.pm + ), + ], }, 'Math::Complex' => { @@ -790,7 +797,7 @@ use File::Glob qw(:case); }, 'Module::CoreList' => { - 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.201509R12tar.gz', + 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20150920.tar.gz', 'FILES' => q[dist/Module-CoreList], }, @@ -810,13 +817,17 @@ use File::Glob qw(:case); }, 'Module::Metadata' => { - 'DISTRIBUTION' => 'ETHER/Module-Metadata-1.000027.tar.gz', + 'DISTRIBUTION' => 'ETHER/Module-Metadata-1.000029-TRIAL.tar.gz', 'FILES' => q[cpan/Module-Metadata], 'EXCLUDED' => [ qw(t/00-report-prereqs.t), qw(t/00-report-prereqs.dd), + qr{weaver.ini}, qr{^xt}, ], + # Already merged upstream: + # https://github.com/Perl-Toolchain-Gang/Module-Metadata/commit/9658697 + 'CUSTOMIZED' => [ qw[ t/lib/GeneratePackage.pm ] ], }, 'Net::Ping' => { @@ -853,11 +864,14 @@ use File::Glob qw(:case); 'PathTools' => { 'DISTRIBUTION' => 'SMUELLER/PathTools-3.47.tar.gz', 'FILES' => q[dist/PathTools], - 'EXCLUDED' => [qr{^t/lib/Test/}], + 'EXCLUDED' => [ + qr{^t/lib/Test/}, + qw( t/rel2abs_vs_symlink.t), + ], }, 'Perl::OSType' => { - 'DISTRIBUTION' => 'DAGOLDEN/Perl-OSType-1.008.tar.gz', + 'DISTRIBUTION' => 'DAGOLDEN/Perl-OSType-1.009.tar.gz', 'FILES' => q[cpan/Perl-OSType], 'EXCLUDED' => [qw(tidyall.ini), qr/^xt/, qr{^t/00-}], }, @@ -993,12 +1007,16 @@ use File::Glob qw(:case); 'FILES' => q[cpan/Socket], # https://rt.cpan.org/Ticket/Display.html?id=106797 - 'CUSTOMIZED' => [ qw[ Socket.xs ] ], + # https://rt.cpan.org/Ticket/Display.html?id=107058 + 'CUSTOMIZED' => [ qw[ Socket.pm Socket.xs ] ], }, 'Storable' => { 'DISTRIBUTION' => 'AMS/Storable-2.51.tar.gz', 'FILES' => q[dist/Storable], + 'EXCLUDED' => [ + qr{^t/compat/}, + ], }, 'Sys::Syslog' => { @@ -1225,7 +1243,7 @@ use File::Glob qw(:case); }, 'Unicode::Normalize' => { - 'DISTRIBUTION' => 'SADAHIRO/Unicode-Normalize-1.19.tar.gz', + 'DISTRIBUTION' => 'KHW/Unicode-Normalize-1.21.tar.gz', 'FILES' => q[cpan/Unicode-Normalize], }, diff --git a/Porting/README.pod b/Porting/README.pod index 84020f6..21a0414 100644 --- a/Porting/README.pod +++ b/Porting/README.pod @@ -42,6 +42,11 @@ Check source code for ANSI-C violations. Used by F to ensure the F list is up to date. +=head2 F + +Check where the symbols defined in the various F-clones +are being used. VMS is probably not handled properly here. + =head2 F Check that the various F-clones have (at least) all the same diff --git a/Porting/checkcfguse.pl b/Porting/checkcfguse.pl new file mode 100755 index 0000000..af3dd12 --- /dev/null +++ b/Porting/checkcfguse.pl @@ -0,0 +1,99 @@ +#!/usr/bin/perl -w + +# +# checkcfguse.pl +# +# (1) finds all the Configure/config symbols +# +# (2) greps for their use in the core files and shows which ones. +# + +use strict; +use warnings; + +my %SYM; + +my @PAT = + ( + [ + # The format is: + # (1) aref of filename glob patterns + # (2) aref of qr patterns, the submatch $1 is the symbol name + [ + "config_h.SH", + ], + [ + qr/^#\$(\w+)\s+(\w+)/, + ], + ], + [ + [ + "NetWare/config_H.??", + "Porting/config.sh", + "plan9/config_h.sample", + "win32/config_H.??", + ], + qr{^(?:\Q/*\E)?#(?:define|undef)\s+(\w+)}, + ], + [ + [ + "configure.com", + ], + qr{^(\w+)="(?:define|undef)"}, + ], + ); + +{ + print STDERR "$0: Looking for symbols...\n"; + for my $pat (@PAT) { + for my $fn (map { glob($_) } @{ $pat->[0] }) { + if (open(my $fh, $fn)) { + while (<$fh>) { + for my $p (@$pat) { + for my $sym (/$p/g) { + $SYM{$sym}{$fn}++; + } + } + } + } + } + } +} + +printf(STDERR "$0: Found %d symbols\n", scalar keys %SYM); + +print STDERR "$0: Looking for their uses...\n"; + +# Much too noisy grepping. +delete $SYM{'_'}; +delete $SYM{'const'}; + +my $SYM = join("|", sort { length($b) <=> length($a) || $a cmp $b } keys %SYM); + +open(my $mani, "MANIFEST") or die "$0: Failed to open MANIFEST\n"; + +my %found; +while (<$mani>) { + if (/^(\S+)\s+/) { + my $fn = $1; + # Skip matches from the config files themselves, + # from metaconfig generated files that refer to + # the config symbols, and from pods. + next if $fn =~ m{^(?:config_h.SH|Configure|configure\.com|Porting/(?:config|Glossary)|(?:NetWare|plan9|win32)/(?:config|(?:GNU)?[Mm]akefile)|uconfig)|\.pod$}; + open my $fh, $fn or die qq[$0: Failed to open $fn: $!]; + while (<$fh>) { + while (/\b($SYM)\b/go) { + $found{$1}{$fn}++; + } + } + } +} + +for my $sym (sort keys %SYM) { + if (exists $found{$sym}) { + my @found = keys %{$found{$sym}}; + print "$sym\t", join(" ", sort @found), "\n"; + } else { + print "$sym\n"; + } +} diff --git a/Porting/config.sh b/Porting/config.sh index d9e029b..cc4675f 100644 --- a/Porting/config.sh +++ b/Porting/config.sh @@ -39,12 +39,12 @@ alignbytes='4' ansi2knr='' aphostname='/bin/hostname' api_revision='5' -api_subversion='3' +api_subversion='4' api_version='23' -api_versionstring='5.23.3' +api_versionstring='5.23.4' ar='ar' -archlib='/pro/lib/perl5/5.23.3/i686-linux-64int' -archlibexp='/pro/lib/perl5/5.23.3/i686-linux-64int' +archlib='/pro/lib/perl5/5.23.4/i686-linux-64int' +archlibexp='/pro/lib/perl5/5.23.4/i686-linux-64int' archname64='64int' archname='i686-linux-64int' archobjs='' @@ -231,11 +231,8 @@ d_fpclassl='undef' d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='define' -d_fs_data_s='undef' d_fseeko='define' d_fsetpos='define' -d_fstatfs='define' -d_fstatvfs='define' d_fsync='define' d_ftello='define' d_ftime='undef' @@ -245,7 +242,6 @@ d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='define' d_getcwd='define' d_getespwnam='undef' -d_getfsstat='undef' d_getgrent='define' d_getgrent_r='undef' d_getgrgid_r='undef' @@ -262,8 +258,6 @@ d_gethostprotos='define' d_getitimer='define' d_getlogin='define' d_getlogin_r='undef' -d_getmnt='undef' -d_getmntent='define' d_getnameinfo='define' d_getnbyaddr='define' d_getnbyname='define' @@ -304,7 +298,6 @@ d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='define' d_grpasswd='define' -d_hasmntopt='define' d_htonl='define' d_hypot='undef' d_ilogb='undef' @@ -532,10 +525,7 @@ d_sresgproto='undef' d_sresuproto='undef' d_stat='define' d_statblks='define' -d_statfs_f_flags='define' -d_statfs_s='define' d_static_inline='define' -d_statvfs='define' d_stdio_cnt_lval='undef' d_stdio_ptr_lval='define' d_stdio_ptr_lval_nochange_cnt='undef' @@ -594,7 +584,6 @@ d_unordered='undef' d_unsetenv='define' d_usleep='define' d_usleepproto='define' -d_ustat='define' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' @@ -745,7 +734,6 @@ i_malloc='define' i_mallocmalloc='undef' i_math='define' i_memory='undef' -i_mntent='define' i_ndbm='define' i_netdb='define' i_neterrno='undef' @@ -776,7 +764,6 @@ i_sysioctl='define' i_syslog='define' i_sysmman='define' i_sysmode='undef' -i_sysmount='define' i_sysndir='undef' i_sysparam='define' i_syspoll='define' @@ -785,8 +772,6 @@ i_syssecrt='undef' i_sysselct='define' i_syssockio='undef' i_sysstat='define' -i_sysstatfs='define' -i_sysstatvfs='define' i_systime='define' i_systimek='undef' i_systimes='define' @@ -794,13 +779,11 @@ i_systypes='define' i_sysuio='define' i_sysun='define' i_sysutsname='define' -i_sysvfs='define' i_syswait='define' i_termio='undef' i_termios='define' i_time='define' i_unistd='define' -i_ustat='define' i_utime='define' i_values='define' i_varargs='undef' @@ -813,7 +796,7 @@ incpath='' incpth='/usr/lib/gcc/i586-suse-linux/4.8/include /usr/local/include /usr/lib/gcc/i586-suse-linux/4.8/include-fixed /usr/lib/gcc/i586-suse-linux/4.8/../../../../i586-suse-linux/include /usr/include' inews='' initialinstalllocation='/pro/bin' -installarchlib='/pro/lib/perl5/5.23.3/i686-linux-64int' +installarchlib='/pro/lib/perl5/5.23.4/i686-linux-64int' installbin='/pro/bin' installhtml1dir='' installhtml3dir='' @@ -821,13 +804,13 @@ installman1dir='/pro/local/man/man1' installman3dir='/pro/local/man/man3' installprefix='/pro' installprefixexp='/pro' -installprivlib='/pro/lib/perl5/5.23.3' +installprivlib='/pro/lib/perl5/5.23.4' installscript='/pro/bin' -installsitearch='/pro/lib/perl5/site_perl/5.23.3/i686-linux-64int' +installsitearch='/pro/lib/perl5/site_perl/5.23.4/i686-linux-64int' installsitebin='/pro/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='/pro/lib/perl5/site_perl/5.23.3' +installsitelib='/pro/lib/perl5/site_perl/5.23.4' installsiteman1dir='/pro/local/man/man1' installsiteman3dir='/pro/local/man/man3' installsitescript='/pro/bin' @@ -953,7 +936,7 @@ perl_patchlevel='' perl_static_inline='static __inline__' perladmin='hmbrand@cpan.org' perllibs='-lnsl -ldl -lm -lcrypt -lutil -lc' -perlpath='/pro/bin/perl5.23.3' +perlpath='/pro/bin/perl5.23.4' pg='pg' phostname='hostname' pidtype='pid_t' @@ -962,8 +945,8 @@ pmake='' pr='' prefix='/pro' prefixexp='/pro' -privlib='/pro/lib/perl5/5.23.3' -privlibexp='/pro/lib/perl5/5.23.3' +privlib='/pro/lib/perl5/5.23.4' +privlibexp='/pro/lib/perl5/5.23.4' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -1029,17 +1012,17 @@ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 6, 17, 29, 31, 0' sig_size='69' signal_t='void' -sitearch='/pro/lib/perl5/site_perl/5.23.3/i686-linux-64int' -sitearchexp='/pro/lib/perl5/site_perl/5.23.3/i686-linux-64int' +sitearch='/pro/lib/perl5/site_perl/5.23.4/i686-linux-64int' +sitearchexp='/pro/lib/perl5/site_perl/5.23.4/i686-linux-64int' sitebin='/pro/bin' sitebinexp='/pro/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/pro/lib/perl5/site_perl/5.23.3' +sitelib='/pro/lib/perl5/site_perl/5.23.4' sitelib_stem='/pro/lib/perl5/site_perl' -sitelibexp='/pro/lib/perl5/site_perl/5.23.3' +sitelibexp='/pro/lib/perl5/site_perl/5.23.4' siteman1dir='/pro/local/man/man1' siteman1direxp='/pro/local/man/man1' siteman3dir='/pro/local/man/man3' @@ -1065,7 +1048,7 @@ src='.' ssizetype='ssize_t' st_ino_sign='1' st_ino_size='8' -startperl='#!/pro/bin/perl5.23.3' +startperl='#!/pro/bin/perl5.23.4' startsh='#!/bin/sh' static_ext=' ' stdchar='char' @@ -1078,7 +1061,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='3' +subversion='4' sysman='/usr/share/man/man1' sysroot='' tail='' @@ -1177,8 +1160,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.23.3' -version_patchlevel_string='version 23 subversion 3' +version='5.23.4' +version_patchlevel_string='version 23 subversion 4' versiononly='define' vi='' xlibpth='/usr/lib/386 /lib/386' @@ -1188,10 +1171,10 @@ zcat='' zip='zip' PERL_REVISION=5 PERL_VERSION=23 -PERL_SUBVERSION=3 +PERL_SUBVERSION=4 PERL_API_REVISION=5 PERL_API_VERSION=23 -PERL_API_SUBVERSION=3 +PERL_API_SUBVERSION=4 PERL_PATCHLEVEL='' PERL_CONFIG_SH=true : Variables propagated from previous config.sh file. diff --git a/Porting/config_H b/Porting/config_H index a54caca..0d32c5d 100644 --- a/Porting/config_H +++ b/Porting/config_H @@ -960,8 +960,8 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "/pro/lib/perl5/5.23.3/i686-linux-64int-ld" /**/ -#define ARCHLIB_EXP "/pro/lib/perl5/5.23.3/i686-linux-64int-ld" /**/ +#define ARCHLIB "/pro/lib/perl5/5.23.4/i686-linux-64int-ld" /**/ +#define ARCHLIB_EXP "/pro/lib/perl5/5.23.4/i686-linux-64int-ld" /**/ /* ARCHNAME: * This symbol holds a string representing the architecture name. @@ -2068,8 +2068,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "/pro/lib/perl5/5.23.3" /**/ -#define PRIVLIB_EXP "/pro/lib/perl5/5.23.3" /**/ +#define PRIVLIB "/pro/lib/perl5/5.23.4" /**/ +#define PRIVLIB_EXP "/pro/lib/perl5/5.23.4" /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor @@ -2119,8 +2119,8 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "/pro/lib/perl5/site_perl/5.23.3/i686-linux-64int-ld" /**/ -#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.23.3/i686-linux-64int-ld" /**/ +#define SITEARCH "/pro/lib/perl5/site_perl/5.23.4/i686-linux-64int-ld" /**/ +#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.23.4/i686-linux-64int-ld" /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -2142,8 +2142,8 @@ * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ -#define SITELIB "/pro/lib/perl5/site_perl/5.23.3" /**/ -#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.23.3" /**/ +#define SITELIB "/pro/lib/perl5/site_perl/5.23.4" /**/ +#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.23.4" /**/ #define SITELIB_STEM "/pro/lib/perl5/site_perl" /**/ /* SSize_t: @@ -2726,36 +2726,6 @@ * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ -/* HAS_MSG_CTRUNC: - * This symbol, if defined, indicates that the MSG_CTRUNC is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_DONTROUTE: - * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_OOB: - * This symbol, if defined, indicates that the MSG_OOB is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PEEK: - * This symbol, if defined, indicates that the MSG_PEEK is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PROXY: - * This symbol, if defined, indicates that the MSG_PROXY is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_SCM_RIGHTS: - * This symbol, if defined, indicates that the SCM_RIGHTS is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ /* HAS_SOCKADDR_SA_LEN: * This symbol, if defined, indicates that the struct sockaddr * structure has a member called sa_len, indicating the length of @@ -2768,12 +2738,6 @@ #define HAS_SOCKET /**/ #define HAS_SOCKETPAIR /**/ /*#define HAS_SOCKADDR_SA_LEN / **/ -#define HAS_MSG_CTRUNC /**/ -#define HAS_MSG_DONTROUTE /**/ -#define HAS_MSG_OOB /**/ -#define HAS_MSG_PEEK /**/ -#define HAS_MSG_PROXY /**/ -#define HAS_SCM_RIGHTS /**/ #define HAS_SIN6_SCOPE_ID /**/ /* USE_STAT_BLOCKS: @@ -3340,24 +3304,12 @@ */ #define HAS_FREXPL /**/ -/* HAS_STRUCT_FS_DATA: - * This symbol, if defined, indicates that the struct fs_data - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_FS_DATA / **/ - /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ #define HAS_FSEEKO /**/ -/* HAS_FSTATFS: - * This symbol, if defined, indicates that the fstatfs routine is - * available to stat filesystems by file descriptors. - */ -#define HAS_FSTATFS /**/ - /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to @@ -3395,30 +3347,12 @@ */ /*#define HAS_GETESPWNAM / **/ -/* HAS_GETFSSTAT: - * This symbol, if defined, indicates that the getfsstat routine is - * available to stat filesystems in bulk. - */ -/*#define HAS_GETFSSTAT / **/ - /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ #define HAS_GETITIMER /**/ -/* HAS_GETMNT: - * This symbol, if defined, indicates that the getmnt routine is - * available to get filesystem mount info by filename. - */ -/*#define HAS_GETMNT / **/ - -/* HAS_GETMNTENT: - * This symbol, if defined, indicates that the getmntent routine is - * available to iterate through mounted file systems to get their info. - */ -#define HAS_GETMNTENT /**/ - /* HAS_GETNAMEINFO: * This symbol, if defined, indicates that the getnameinfo() function * is available for use. @@ -3437,12 +3371,6 @@ */ #define HAS_GETSPNAM /**/ -/* HAS_HASMNTOPT: - * This symbol, if defined, indicates that the hasmntopt routine is - * available to query the mount options of file systems. - */ -#define HAS_HASMNTOPT /**/ - /* HAS_ILOGBL: * This symbol, if defined, indicates that the ilogbl routine is * available. If scalbnl is also present we can emulate frexpl. @@ -3547,16 +3475,8 @@ * a prototype for the modfl() function. Otherwise, it is up * to the program to supply one. */ -/* HAS_MODFL_POW32_BUG: - * This symbol, if defined, indicates that the modfl routine is - * broken for long doubles >= pow(2, 32). - * For example from 4294967303.150000 one would get 4294967302.000000 - * and 1.150000. The bug has been seen in certain versions of glibc, - * release 2.2.2 is known to be okay. - */ #define HAS_MODFL /**/ #define HAS_MODFL_PROTO /**/ -/*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is @@ -3746,29 +3666,6 @@ */ /*#define HAS_SETRESUID_PROTO / **/ -/* HAS_STRUCT_STATFS_F_FLAGS: - * This symbol, if defined, indicates that the struct statfs - * does have the f_flags member containing the mount flags of - * the filesystem containing the file. - * This kind of struct statfs is coming from (BSD 4.3), - * not from (SYSV). Older BSDs (like Ultrix) do not - * have statfs() and struct statfs, they have ustat() and getmnt() - * with struct ustat and struct fs_data. - */ -/*#define HAS_STRUCT_STATFS_F_FLAGS / **/ - -/* HAS_STRUCT_STATFS: - * This symbol, if defined, indicates that the struct statfs - * to do statfs() is supported. - */ -#define HAS_STRUCT_STATFS /**/ - -/* HAS_FSTATVFS: - * This symbol, if defined, indicates that the fstatvfs routine is - * available to stat filesystems by file descriptors. - */ -#define HAS_FSTATVFS /**/ - /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. @@ -3906,12 +3803,6 @@ */ #define HAS_USLEEP_PROTO /**/ -/* HAS_USTAT: - * This symbol, if defined, indicates that the ustat system call is - * available to query file system statistics by dev_t. - */ -#define HAS_USTAT /**/ - /* HAS_WRITEV: * This symbol, if defined, indicates that the writev routine is * available to do scatter writes. @@ -4022,12 +3913,6 @@ */ /*#define I_MALLOCMALLOC / **/ -/* I_MNTENT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -#define I_MNTENT /**/ - /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . @@ -4076,41 +3961,12 @@ */ /*#define I_SYSMODE / **/ -/* I_SYS_MOUNT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -#define I_SYS_MOUNT /**/ - -/* I_SYS_STATFS: - * This symbol, if defined, indicates that exists. - */ -#define I_SYS_STATFS /**/ - -/* I_SYS_STATVFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -#define I_SYS_STATVFS /**/ - /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ #define I_SYSUTSNAME /**/ -/* I_SYS_VFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -#define I_SYS_VFS /**/ - -/* I_USTAT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -#define I_USTAT /**/ - /* PERL_PRIfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for output. @@ -4326,7 +4182,7 @@ * script to make sure (one hopes) that it runs with perl and not * some shell. */ -#define STARTPERL "#!/pro/bin/perl5.23.3" /**/ +#define STARTPERL "#!/pro/bin/perl5.23.4" /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array diff --git a/Porting/epigraphs.pod b/Porting/epigraphs.pod index be3dbee..8e02447 100644 --- a/Porting/epigraphs.pod +++ b/Porting/epigraphs.pod @@ -17,6 +17,18 @@ Consult your favorite dictionary for details. =head1 EPIGRAPHS +=head2 v5.23.3 - Oliver Wendell Holmes, "The Deacon’s Masterpiece or The Wonderful 'One-Hoss Shay': A Logical Story" + +L + + Little of of all we value here + Wakes on the morn of its hundredth year + Without both feeling and looking queer. + In fact, there’s nothing that keeps its youth, + So far as I know, but a tree and truth. + (This is a moral that runs at large; + Take it. — You’re welcome. — No extra charge.) + =head2 v5.23.2 - Blind Guardian, "Skalds and Shadows" L diff --git a/Porting/exec-bit.txt b/Porting/exec-bit.txt index a0c91e0..4504c52 100644 --- a/Porting/exec-bit.txt +++ b/Porting/exec-bit.txt @@ -38,6 +38,7 @@ Porting/checkAUTHORS.pl Porting/checkURL.pl Porting/checkVERSION.pl Porting/checkansi.pl +Porting/checkcfguse.pl Porting/checkcfgvar.pl Porting/checkpodencoding.pl Porting/cmpVERSION.pl diff --git a/Porting/makerel b/Porting/makerel index a2160fb..0bf7990 100755 --- a/Porting/makerel +++ b/Porting/makerel @@ -148,12 +148,14 @@ my @writables = qw( perlapi.c cpan/Devel-PPPort/module2.c cpan/Devel-PPPort/module3.c + cpan/autodie/t/touch_me reentr.c reentr.h regcharclass.h regnodes.h warnings.h lib/warnings.pm + win32/GNUmakefile win32/Makefile win32/Makefile.ce win32/makefile.mk diff --git a/Porting/perldelta_template.pod b/Porting/perldelta_template.pod index fc7e1de..1892224 100644 --- a/Porting/perldelta_template.pod +++ b/Porting/perldelta_template.pod @@ -378,7 +378,7 @@ here. XXX Generate this with: - perl Porting/acknowledgements.pl v5.23.3..HEAD + perl Porting/acknowledgements.pl v5.23.4..HEAD =head1 Reporting Bugs diff --git a/Porting/release_schedule.pod b/Porting/release_schedule.pod index 2c2b847..c408776 100644 --- a/Porting/release_schedule.pod +++ b/Porting/release_schedule.pod @@ -54,7 +54,7 @@ you should reset the version numbers to the next blead series. 2015-06-20 5.23.0 ✓ Ricardo Signes 2015-07-20 5.23.1 ✓ Matthew Horsfall 2015-08-20 5.23.2 ✓ Matthew Horsfall - 2015-09-20 5.23.3 Peter Martini + 2015-09-20 5.23.3 ✓ Peter Martini 2015-10-20 5.23.4 Steve Hay 2015-11-20 5.23.5 Abigail 2015-12-20 5.23.6 David Golden diff --git a/Porting/todo.pod b/Porting/todo.pod index b23764b..8870934 100644 --- a/Porting/todo.pod +++ b/Porting/todo.pod @@ -467,7 +467,7 @@ Natively 64-bit systems need neither -Duse64bitint nor -Duse64bitall. On these systems, it might be the default compilation mode, and there is currently no guarantee that passing no use64bitall option to the Configure process will build a 32bit perl. Implementing -Duse32bit* -options would be nice for perl 5.23.3. +options would be nice for perl 5.23.4. =head2 Profile Perl - am I hot or not? @@ -1169,7 +1169,7 @@ L =head1 Big projects Tasks that will get your name mentioned in the description of the "Highlights -of 5.23.3" +of 5.23.4" =head2 make ithreads more robust diff --git a/README.haiku b/README.haiku index 95e3b15..55d62db 100644 --- a/README.haiku +++ b/README.haiku @@ -22,9 +22,9 @@ The build procedure is completely standard: Make perl executable and create a symlink for libperl: chmod a+x /boot/common/bin/perl - cd /boot/common/lib; ln -s perl5/5.23.3/BePC-haiku/CORE/libperl.so . + cd /boot/common/lib; ln -s perl5/5.23.4/BePC-haiku/CORE/libperl.so . -Replace C<5.23.3> with your respective version of Perl. +Replace C<5.23.4> with your respective version of Perl. =head1 KNOWN PROBLEMS diff --git a/README.macosx b/README.macosx index 2a58067..2a71c4e 100644 --- a/README.macosx +++ b/README.macosx @@ -10,9 +10,9 @@ perlmacosx - Perl under Mac OS X This document briefly describes Perl under Mac OS X. - curl -O http://www.cpan.org/src/perl-5.23.3.tar.gz - tar -xzf perl-5.23.3.tar.gz - cd perl-5.23.3 + curl -O http://www.cpan.org/src/perl-5.23.4.tar.gz + tar -xzf perl-5.23.4.tar.gz + cd perl-5.23.4 ./Configure -des -Dprefix=/usr/local/ make make test @@ -20,7 +20,7 @@ This document briefly describes Perl under Mac OS X. =head1 DESCRIPTION -The latest Perl release (5.23.3 as of this writing) builds without changes +The latest Perl release (5.23.4 as of this writing) builds without changes under all versions of Mac OS X from 10.3 "Panther" onwards. In order to build your own version of Perl you will need 'make', diff --git a/README.os2 b/README.os2 index 464104a..b848d66 100644 --- a/README.os2 +++ b/README.os2 @@ -619,7 +619,7 @@ C in F, see L<"PERLLIB_PREFIX">. =item Additional Perl modules - unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.23.3/ + unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.23.4/ Same remark as above applies. Additionally, if this directory is not one of directories on @INC (and @INC is influenced by C), you diff --git a/README.vms b/README.vms index 1716a5f..0046dd3 100644 --- a/README.vms +++ b/README.vms @@ -142,11 +142,11 @@ You may need to set up a foreign symbol for the unpacking utility of choice. Once you have done so, use a command like the following to unpack the archive: - vmstar -xvf perl-5^.23^.3.tar + vmstar -xvf perl-5^.23^.4.tar Then set default to the top-level source directory like so: - set default [.perl-5^.23^.3] + set default [.perl-5^.23^.4] and proceed with configuration as described in the next section. diff --git a/README.win32 b/README.win32 index 2a8651a..6726019 100644 --- a/README.win32 +++ b/README.win32 @@ -485,10 +485,14 @@ You can also control the shell that perl uses to run system() and backtick commands via PERL5SHELL. See L. Perl does not depend on the registry, but it can look up certain default -values if you choose to put them there. Perl attempts to read entries from -C and C. -Entries in the former override entries in the latter. One or more of the -following entries (of type REG_SZ or REG_EXPAND_SZ) may be set: +values if you choose to put them there unless disabled at build time with +USE_NO_REGISTRY. On Perl process start Perl checks if +C and C +exist. If the keys exists, they will be checked for remainder of the Perl +process's run life for certain entries. Entries in +C override entries in +C. One or more of the following entries +(of type REG_SZ or REG_EXPAND_SZ) may be set in the keys: lib-$] version-specific standard library path to add to @INC lib standard library path to add to @INC diff --git a/XSUB.h b/XSUB.h index 4548fc9..e64bc83 100644 --- a/XSUB.h +++ b/XSUB.h @@ -327,6 +327,7 @@ Rethrows a previously caught exception. See L. #define XSRETURN(off) \ STMT_START { \ const IV tmpXSoff = (off); \ + assert(tmpXSoff >= 0);\ PL_stack_sp = PL_stack_base + ax + (tmpXSoff - 1); \ return; \ } STMT_END diff --git a/autodoc.pl b/autodoc.pl index b27fc4d..4a55c3c 100644 --- a/autodoc.pl +++ b/autodoc.pl @@ -304,11 +304,14 @@ interfaces are subject to change. Functions that are not listed in this document are not intended for public use, and should NOT be used under any circumstances. -If you use one of the undocumented functions below, you may wish to consider -creating and submitting documentation -for it. If your patch is accepted, this -will indicate that the interface is stable (unless it is explicitly marked -otherwise). +If you feel you need to use one of these functions, first send email to +L. It may be +that there is a good reason for the function not being documented, and it +should be removed from this list; or it may just be that no one has gotten +around to documenting it. In the latter case, you will be asked to submit a +patch to document the function. Once your patch is accepted, it will indicate +that the interface is stable (unless it is explicitly marked otherwise) and +usable by you. =over diff --git a/av.c b/av.c index cb99ceb..9a5644a 100644 --- a/av.c +++ b/av.c @@ -87,6 +87,10 @@ Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp, { PERL_ARGS_ASSERT_AV_EXTEND_GUTS; + if (key < -1) /* -1 is legal */ + Perl_croak(aTHX_ + "panic: av_extend_guts() negative count (%"IVdf")", (IV)key); + if (key > *maxp) { SV** ary; SSize_t tmp; @@ -432,11 +436,15 @@ Perl_av_make(pTHX_ SSize_t size, SV **strp) /* =for apidoc av_clear -Clears an array, making it empty. Does not free the memory C uses to -store its list of scalars. If any destructors are triggered as a result, -C itself may be freed when this function returns. +Frees the all the elements of an array, leaving it empty. +The XS equivalent of C<@array = ()>. See also L. -Perl equivalent: C<@myarray = ();>. +Note that it is possible that the actions of a destructor called directly +or indirectly by freeing an element of the array could cause the reference +count of the array itself to be reduced (e.g. by deleting an entry in the +symbol table). So it is a possibility that the AV could have been freed +(or even reallocated) on return from the call unless you hold a reference +to it. =cut */ @@ -496,9 +504,13 @@ Perl_av_clear(pTHX_ AV *av) /* =for apidoc av_undef -Undefines the array. Frees the memory used by the av to store its list of -scalars. If any destructors are triggered as a result, C itself may -be freed. +Undefines the array. The XS equivalent of C. + +As well as freeing all the elements of the array (like C), this +also frees the memory used by the av to store its list of scalars. + +See L for a note about the array possibly being invalid on +return. =cut */ diff --git a/charclass_invlists.h b/charclass_invlists.h index a9ff0ca..893b2f0 100644 --- a/charclass_invlists.h +++ b/charclass_invlists.h @@ -99537,7 +99537,7 @@ static const UV XPosixXDigit_invlist[] = { /* for EBCDIC POSIX-BC */ * 1a0687fb9c6c4567e853913549df0944fe40821279a3e9cdaa6ab8679bc286fd lib/unicore/extracted/DLineBreak.txt * 40bcfed3ca727c19e1331f6c33806231d5f7eeeabd2e6a9e06a3740c85d0c250 lib/unicore/extracted/DNumType.txt * a18d502bad39d527ac5586d7bc93e29f565859e3bcc24ada627eff606d6f5fed lib/unicore/extracted/DNumValues.txt - * 00c1bda0498082b8245a27cca31028ec97b90ad717b00281ea023d25e11428f1 lib/unicore/mktables + * 6096850989ab3bc78543045021ede0b02708937b5b0f860991a0ac0373552d02 lib/unicore/mktables * 462c9aaa608fb2014cd9649af1c5c009485c60b9c8b15b89401fdc10cf6161c6 lib/unicore/version * c6884f4d629f04d1316f3476cb1050b6a1b98ca30c903262955d4eae337c6b1e regen/charset_translations.pl * 8a097f8f726bb1619af2f27f149ab87e60a1602f790147e3a561358be16abd27 regen/mk_invlists.pl diff --git a/config_h.SH b/config_h.SH index 0d4a409..8bc6b98 100755 --- a/config_h.SH +++ b/config_h.SH @@ -2359,36 +2359,6 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ -/* HAS_MSG_CTRUNC: - * This symbol, if defined, indicates that the MSG_CTRUNC is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_DONTROUTE: - * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_OOB: - * This symbol, if defined, indicates that the MSG_OOB is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PEEK: - * This symbol, if defined, indicates that the MSG_PEEK is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PROXY: - * This symbol, if defined, indicates that the MSG_PROXY is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_SCM_RIGHTS: - * This symbol, if defined, indicates that the SCM_RIGHTS is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ /* HAS_SOCKADDR_SA_LEN: * This symbol, if defined, indicates that the struct sockaddr * structure has a member called sa_len, indicating the length of @@ -2421,12 +2391,6 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #$d_socket HAS_SOCKET /**/ #$d_sockpair HAS_SOCKETPAIR /**/ #$d_sockaddr_sa_len HAS_SOCKADDR_SA_LEN /**/ -#$d_msg_ctrunc HAS_MSG_CTRUNC /**/ -#$d_msg_dontroute HAS_MSG_DONTROUTE /**/ -#$d_msg_oob HAS_MSG_OOB /**/ -#$d_msg_peek HAS_MSG_PEEK /**/ -#$d_msg_proxy HAS_MSG_PROXY /**/ -#$d_scm_rights HAS_SCM_RIGHTS /**/ #$d_sockaddr_in6 HAS_SOCKADDR_IN6 /**/ #$d_sin6_scope_id HAS_SIN6_SCOPE_ID /**/ #$d_ip_mreq HAS_IP_MREQ /**/ @@ -3747,24 +3711,12 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_frexpl HAS_FREXPL /**/ -/* HAS_STRUCT_FS_DATA: - * This symbol, if defined, indicates that the struct fs_data - * to do statfs() is supported. - */ -#$d_fs_data_s HAS_STRUCT_FS_DATA /**/ - /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ #$d_fseeko HAS_FSEEKO /**/ -/* HAS_FSTATFS: - * This symbol, if defined, indicates that the fstatfs routine is - * available to stat filesystems by file descriptors. - */ -#$d_fstatfs HAS_FSTATFS /**/ - /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to @@ -3802,30 +3754,12 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_getespwnam HAS_GETESPWNAM /**/ -/* HAS_GETFSSTAT: - * This symbol, if defined, indicates that the getfsstat routine is - * available to stat filesystems in bulk. - */ -#$d_getfsstat HAS_GETFSSTAT /**/ - /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ #$d_getitimer HAS_GETITIMER /**/ -/* HAS_GETMNT: - * This symbol, if defined, indicates that the getmnt routine is - * available to get filesystem mount info by filename. - */ -#$d_getmnt HAS_GETMNT /**/ - -/* HAS_GETMNTENT: - * This symbol, if defined, indicates that the getmntent routine is - * available to iterate through mounted file systems to get their info. - */ -#$d_getmntent HAS_GETMNTENT /**/ - /* HAS_GETNAMEINFO: * This symbol, if defined, indicates that the getnameinfo() function * is available for use. @@ -3844,12 +3778,6 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_getspnam HAS_GETSPNAM /**/ -/* HAS_HASMNTOPT: - * This symbol, if defined, indicates that the hasmntopt routine is - * available to query the mount options of file systems. - */ -#$d_hasmntopt HAS_HASMNTOPT /**/ - /* HAS_HYPOT: * This symbol, if defined, indicates that the hypot routine is * available to do the hypotenuse function. @@ -4102,16 +4030,8 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * a prototype for the modfl() function. Otherwise, it is up * to the program to supply one. */ -/* HAS_MODFL_POW32_BUG: - * This symbol, if defined, indicates that the modfl routine is - * broken for long doubles >= pow(2, 32). - * For example from 4294967303.150000 one would get 4294967302.000000 - * and 1.150000. The bug has been seen in certain versions of glibc, - * release 2.2.2 is known to be okay. - */ #$d_modfl HAS_MODFL /**/ #$d_modflproto HAS_MODFL_PROTO /**/ -#$d_modfl_pow32_bug HAS_MODFL_POW32_BUG /**/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is @@ -4367,29 +4287,6 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_sresuproto HAS_SETRESUID_PROTO /**/ -/* HAS_STRUCT_STATFS_F_FLAGS: - * This symbol, if defined, indicates that the struct statfs - * does have the f_flags member containing the mount flags of - * the filesystem containing the file. - * This kind of struct statfs is coming from (BSD 4.3), - * not from (SYSV). Older BSDs (like Ultrix) do not - * have statfs() and struct statfs, they have ustat() and getmnt() - * with struct ustat and struct fs_data. - */ -#$d_statfs_f_flags HAS_STRUCT_STATFS_F_FLAGS /**/ - -/* HAS_STRUCT_STATFS: - * This symbol, if defined, indicates that the struct statfs - * to do statfs() is supported. - */ -#$d_statfs_s HAS_STRUCT_STATFS /**/ - -/* HAS_FSTATVFS: - * This symbol, if defined, indicates that the fstatvfs routine is - * available to stat filesystems by file descriptors. - */ -#$d_fstatvfs HAS_FSTATVFS /**/ - /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. @@ -4545,12 +4442,6 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_usleepproto HAS_USLEEP_PROTO /**/ -/* HAS_USTAT: - * This symbol, if defined, indicates that the ustat system call is - * available to query file system statistics by dev_t. - */ -#$d_ustat HAS_USTAT /**/ - /* HAS_WCSCMP: * This symbol, if defined, indicates that the wcscmp routine is * available to compare two wide character strings. @@ -4687,12 +4578,6 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$i_mallocmalloc I_MALLOCMALLOC /**/ -/* I_MNTENT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -#$i_mntent I_MNTENT /**/ - /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . @@ -4759,41 +4644,12 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$i_sysmode I_SYSMODE /**/ -/* I_SYS_MOUNT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -#$i_sysmount I_SYS_MOUNT /**/ - -/* I_SYS_STATFS: - * This symbol, if defined, indicates that exists. - */ -#$i_sysstatfs I_SYS_STATFS /**/ - -/* I_SYS_STATVFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -#$i_sysstatvfs I_SYS_STATVFS /**/ - /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ #$i_sysutsname I_SYSUTSNAME /**/ -/* I_SYS_VFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -#$i_sysvfs I_SYS_VFS /**/ - -/* I_USTAT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -#$i_ustat I_USTAT /**/ - /* DOUBLEINFBYTES: * This symbol, if defined, is a comma-separated list of * hexadecimal bytes for the double precision infinity. diff --git a/configure.com b/configure.com index b0928a4..53fdd6a 100644 --- a/configure.com +++ b/configure.com @@ -5277,20 +5277,6 @@ $ d_setreuid = "define" $ d_setsid = "define" $ endif $! -$! VMS V8 powered options -$! We know that it is only available for 8.2 and later on 64 bit platforms. -$! -$ d_fstatvfs = "undef" -$ d_statvfs = "undef" -$ i_sysstatvfs = "undef" -$ if (vms_ver .GES. "8.2") -$ then -$ echo "Found 64 bit OpenVMS ''vms_ver' -- will build with 8.2 routines" -$ d_fstatvfs = "define" -$ d_statvfs = "define" -$ i_sysstatvfs = "define" -$ endif -$! $! Check rand48 and its ilk $! $ echo4 "Using our internal random number implementation..." @@ -6038,11 +6024,8 @@ $ WC "d_fpclassl='undef'" $ WC "d_fpgetround='undef'" $ WC "d_fpos64_t='" + d_fpos64_t + "'" $ WC "d_frexpl='" + d_frexpl + "'" -$ WC "d_fs_data_s='undef'" $ WC "d_fseeko='" + d_fseeko + "'" $ WC "d_fsetpos='define'" -$ WC "d_fstatfs='undef'" -$ WC "d_fstatvfs='" + d_fstatvfs + "'" $ WC "d_fsync='define'" $ WC "d_ftello='" + d_ftello + "'" $ WC "d_ftime='define'" @@ -6052,7 +6035,6 @@ $ WC "d_gdbm_ndbm_h_uses_prototypes='undef'" $ WC "d_getaddrinfo='define'" $ WC "d_getcwd='define'" $ WC "d_getespwnam='undef'" -$ WC "d_getfsstat='undef'" $ WC "d_getgrent='define'" $ WC "d_getgrps='undef'" $ WC "d_gethbyaddr='" + d_gethbyaddr + "'" @@ -6062,8 +6044,6 @@ $ WC "d_gethname='" + d_gethname + "'" $ WC "d_gethostprotos='" + d_gethostprotos + "'" $ WC "d_getitimer='" + d_getitimer + "'" $ WC "d_getlogin='define'" -$ WC "d_getmnt='undef'" -$ WC "d_getmntent='undef'" $ WC "d_getnameinfo='define'" $ WC "d_getnbyaddr='" + d_getnbyaddr + "'" $ WC "d_getnbyname='" + d_getnbyname + "'" @@ -6090,7 +6070,6 @@ $ WC "d_gettimeod='" + d_gettimeod + "'" $ WC "d_gmtime64='undef'" $ WC "d_gnulibc='undef'" $ WC "d_grpasswd='undef'" -$ WC "d_hasmntopt='undef'" $ WC "d_htonl='" + d_htonl + "'" $ WC "d_hypot='" + d_hypot + "'" $ WC "d_ilogb='" + d_ilogb + "'" @@ -6117,7 +6096,7 @@ $ WC "d_isnanl='" + d_isnanl + "'" $ WC "d_isnormal='" + d_isnormal + "'" $ WC "d_j0='" + d_j0 + "'" $ WC "d_j0l='undef'" -$ WC "d_killpg='undef'" +$ WC "d_killpg='define'" $ WC "d_lchown='" + d_lchown + "'" $ WC "d_ldbl_dig='define'" $ WC "d_ldexpl='" + d_ldexpl + "'" @@ -6319,9 +6298,6 @@ $ WC "d_sresproto='undef'" $ WC "d_sresuproto='undef'" $ WC "d_stat='define'" $ WC "d_statblks='undef'" -$ WC "d_statfs_f_flags='undef'" -$ WC "d_statfs_s='undef'" -$ WC "d_statfsflags='undef'" $ WC "d_static_inline='define'" $ WC "d_stdio_cnt_lval='" + d_stdio_cnt_lval + "'" $ WC "d_stdio_ptr_lval='" + d_stdio_ptr_lval + "'" @@ -6331,7 +6307,6 @@ $ WC "d_stdio_stream_array='undef'" $ WC "d_stdiobase='" + d_stdiobase + "'" $ WC "d_stdstdio='" + d_stdstdio + "'" $ WC "d_faststdio='" + d_faststdio + "'" -$ WC "d_statvfs='" + d_statvfs + "'" $ WC "d_strchr='define'" $ WC "d_strcoll='" + d_strcoll + "'" $ WC "d_strctcpy='define'" @@ -6388,7 +6363,6 @@ $ WC "d_unsetenv='" + d_unsetenv + "'" $ WC "d_clearenv='" + d_clearenv + "'" $ WC "d_usleep='" + d_usleep + "'" $ WC "d_usleepproto='" + d_usleep + "'" -$ WC "d_ustat='undef'" $ WC "d_vendorarch='undef'" $ WC "d_vendorbin='undef'" $ WC "d_vendorlib='undef'" @@ -6500,7 +6474,6 @@ $ WC "i_malloc='undef'" $ WC "i_mallocmalloc='undef'" $ WC "i_math='define'" $ WC "i_memory='undef'" -$ WC "i_mntent='undef'" $ WC "i_ndbm='undef'" $ WC "i_netdb='" + i_netdb + "'" $ WC "i_neterrno='define'" @@ -6536,7 +6509,6 @@ $ WC "i_sysioctl='" + i_sysioctl + "'" $ WC "i_syslog='" + i_syslog + "'" $ WC "i_sysmman='undef'" $ WC "i_sysmode='" + i_sysmode + "'" -$ WC "i_sysmount='undef'" $ WC "i_sysndir='undef'" $ WC "i_sysparam='undef'" $ WC "i_syspoll='" + i_syspoll + "'" @@ -6545,8 +6517,6 @@ $ WC "i_syssecrt='" + i_syssecrt + "'" $ WC "i_sysselct='undef'" $ WC "i_syssockio='undef'" $ WC "i_sysstat='define'" -$ WC "i_sysstatfs='undef'" -$ WC "i_sysstatvfs='" + i_sysstatvfs + "'" $ WC "i_systime='undef'" $ WC "i_systimek='undef'" $ WC "i_systimes='undef'" @@ -6554,13 +6524,11 @@ $ WC "i_systypes='define'" $ WC "i_sysuio='" + i_sysuio + "'" $ WC "i_sysun='" + i_sysun + "'" $ WC "i_sysutsname='" + i_sysutsname + "'" -$ WC "i_sysvfs='undef'" $ WC "i_syswait='undef'" $ WC "i_termio='undef'" $ WC "i_termios='undef'" $ WC "i_time='define'" $ WC "i_unistd='" + i_unistd + "'" -$ WC "i_ustat='undef'" $ WC "i_utime='" + i_utime + "'" $ WC "i_values='undef'" $ WC "i_varargs='undef'" diff --git a/cop.h b/cop.h index aae9cea7..d36d189 100644 --- a/cop.h +++ b/cop.h @@ -34,6 +34,7 @@ struct jmpenv { Sigjmp_buf je_buf; /* uninit if je_prev is NULL */ int je_ret; /* last exception thrown */ bool je_mustcatch; /* need to call longjmp()? */ + U16 je_old_delaymagic; /* saved PL_delaymagic */ }; typedef struct jmpenv JMPENV; @@ -55,6 +56,7 @@ typedef struct jmpenv JMPENV; PL_start_env.je_prev = NULL; \ PL_start_env.je_ret = -1; \ PL_start_env.je_mustcatch = TRUE; \ + PL_start_env.je_old_delaymagic = 0; \ } STMT_END /* @@ -103,6 +105,7 @@ typedef struct jmpenv JMPENV; cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, SCOPE_SAVES_SIGNAL_MASK); \ PL_top_env = &cur_env; \ cur_env.je_mustcatch = FALSE; \ + cur_env.je_old_delaymagic = PL_delaymagic; \ (v) = cur_env.je_ret; \ } STMT_END @@ -114,6 +117,7 @@ typedef struct jmpenv JMPENV; Perl_deb(aTHX_ "JUMPENV_POP level=%d at %s:%d\n", \ i, __FILE__, __LINE__);}) \ assert(PL_top_env == &cur_env); \ + PL_delaymagic = cur_env.je_old_delaymagic; \ PL_top_env = cur_env.je_prev; \ } STMT_END diff --git a/cpan/Compress-Raw-Bzip2/Bzip2.xs b/cpan/Compress-Raw-Bzip2/Bzip2.xs index 17924c7..e47dbae 100644 --- a/cpan/Compress-Raw-Bzip2/Bzip2.xs +++ b/cpan/Compress-Raw-Bzip2/Bzip2.xs @@ -101,9 +101,10 @@ static const char my_z_errmsg[][32] = { # define NO_WRITEABLE_DATA #endif +/* Set TRACE_DEFAULT to a non-zero value to enable tracing */ #define TRACE_DEFAULT 0 -#ifdef NO_WRITEABLE_DATA +#if defined(NO_WRITEABLE_DATA) || TRACE_DEFAULT == 0 # define trace TRACE_DEFAULT #else static int trace = TRACE_DEFAULT ; @@ -133,18 +134,7 @@ GetErrorString(error_no) int error_no ; #endif { - dTHX; - char * errstr ; - -#if 0 - if (error_no == BZ_ERRNO) { - errstr = Strerror(errno) ; - } - else -#endif - errstr = (char*) my_z_errmsg[4 - error_no]; - - return errstr ; + return(char*) my_z_errmsg[4 - error_no]; } static void @@ -344,9 +334,6 @@ PROTOTYPES: DISABLE INCLUDE: constants.xs BOOT: -#ifndef NO_WRITEABLE_DATA - trace = TRACE_DEFAULT ; -#endif /* Check this version of bzip2 is == 1 */ if (BZ2_bzlibVersion()[0] != '1') croak(COMPRESS_CLASS " needs bzip2 version 1.x, you have %s\n", BZ2_bzlibVersion()) ; diff --git a/cpan/Compress-Raw-Bzip2/bzip2-src/blocksort.c b/cpan/Compress-Raw-Bzip2/bzip2-src/blocksort.c index d0d662c..605b665 100644 --- a/cpan/Compress-Raw-Bzip2/bzip2-src/blocksort.c +++ b/cpan/Compress-Raw-Bzip2/bzip2-src/blocksort.c @@ -202,9 +202,9 @@ void fallbackQSort3 ( UInt32* fmap, bhtab [ 0 .. 2+(nblock/32) ] destroyed */ -#define SET_BH(zz) bhtab[(zz) >> 5] |= (1 << ((zz) & 31)) -#define CLEAR_BH(zz) bhtab[(zz) >> 5] &= ~(1 << ((zz) & 31)) -#define ISSET_BH(zz) (bhtab[(zz) >> 5] & (1 << ((zz) & 31))) +#define SET_BH(zz) bhtab[(zz) >> 5] |= (1U << ((zz) & 31)) +#define CLEAR_BH(zz) bhtab[(zz) >> 5] &= ~(1U << ((zz) & 31)) +#define ISSET_BH(zz) (bhtab[(zz) >> 5] & (1U << ((zz) & 31))) #define WORD_BH(zz) bhtab[(zz) >> 5] #define UNALIGNED_BH(zz) ((zz) & 0x01f) @@ -477,7 +477,7 @@ Bool mainGtU ( UInt32 i1, usually small, typically <= 20. --*/ static -Int32 incs[14] = { 1, 4, 13, 40, 121, 364, 1093, 3280, +const Int32 incs[14] = { 1, 4, 13, 40, 121, 364, 1093, 3280, 9841, 29524, 88573, 265720, 797161, 2391484 }; diff --git a/cpan/Compress-Raw-Bzip2/bzip2-src/bzlib_private.h b/cpan/Compress-Raw-Bzip2/bzip2-src/bzlib_private.h index 5d0217f..a18585d 100644 --- a/cpan/Compress-Raw-Bzip2/bzip2-src/bzlib_private.h +++ b/cpan/Compress-Raw-Bzip2/bzip2-src/bzlib_private.h @@ -128,7 +128,7 @@ extern void bz_internal_error ( int errcode ); /*-- Stuff for randomising repetitive blocks. --*/ -extern Int32 BZ2_rNums[512]; +extern const Int32 BZ2_rNums[512]; #define BZ_RAND_DECLS \ Int32 rNToGo; \ @@ -152,7 +152,7 @@ extern Int32 BZ2_rNums[512]; /*-- Stuff for doing CRCs. --*/ -extern UInt32 BZ2_crc32Table[256]; +extern const UInt32 BZ2_crc32Table[256]; #define BZ_INITIALISE_CRC(crcVar) \ { \ diff --git a/cpan/Compress-Raw-Bzip2/bzip2-src/crctable.c b/cpan/Compress-Raw-Bzip2/bzip2-src/crctable.c index 1fea7e9..9616312 100644 --- a/cpan/Compress-Raw-Bzip2/bzip2-src/crctable.c +++ b/cpan/Compress-Raw-Bzip2/bzip2-src/crctable.c @@ -28,7 +28,7 @@ comp.compression FAQ. --*/ -UInt32 BZ2_crc32Table[256] = { +const UInt32 BZ2_crc32Table[256] = { /*-- Ugly, innit? --*/ diff --git a/cpan/Compress-Raw-Bzip2/bzip2-src/randtable.c b/cpan/Compress-Raw-Bzip2/bzip2-src/randtable.c index 6d62459..4a2fd18 100644 --- a/cpan/Compress-Raw-Bzip2/bzip2-src/randtable.c +++ b/cpan/Compress-Raw-Bzip2/bzip2-src/randtable.c @@ -23,7 +23,7 @@ /*---------------------------------------------*/ -Int32 BZ2_rNums[512] = { +const Int32 BZ2_rNums[512] = { 619, 720, 127, 481, 931, 816, 813, 233, 566, 247, 985, 724, 205, 454, 863, 491, 741, 242, 949, 214, 733, 859, 335, 708, 621, 574, 73, 654, 730, 472, diff --git a/cpan/Compress-Raw-Bzip2/lib/Compress/Raw/Bzip2.pm b/cpan/Compress-Raw-Bzip2/lib/Compress/Raw/Bzip2.pm index a5cdc2f..d9e25bd 100644 --- a/cpan/Compress-Raw-Bzip2/lib/Compress/Raw/Bzip2.pm +++ b/cpan/Compress-Raw-Bzip2/lib/Compress/Raw/Bzip2.pm @@ -11,7 +11,7 @@ use Carp ; use bytes ; our ($VERSION, $XS_VERSION, @ISA, @EXPORT, $AUTOLOAD); -$VERSION = '2.068'; +$VERSION = '2.069'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -378,7 +378,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Compress-Raw-Bzip2/t/000prereq.t b/cpan/Compress-Raw-Bzip2/t/000prereq.t index e63b595..ebe0f50 100644 --- a/cpan/Compress-Raw-Bzip2/t/000prereq.t +++ b/cpan/Compress-Raw-Bzip2/t/000prereq.t @@ -19,7 +19,7 @@ BEGIN if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - my $VERSION = '2.068'; + my $VERSION = '2.069'; my @NAMES = qw( ); diff --git a/cpan/Compress-Raw-Zlib/Zlib.xs b/cpan/Compress-Raw-Zlib/Zlib.xs index 0184062..664c26c 100644 --- a/cpan/Compress-Raw-Zlib/Zlib.xs +++ b/cpan/Compress-Raw-Zlib/Zlib.xs @@ -274,9 +274,10 @@ static const char my_z_errmsg[][32] = { # define NO_WRITEABLE_DATA #endif +/* Set TRACE_DEFAULT to a non-zero value to enable tracing */ #define TRACE_DEFAULT 0 -#ifdef NO_WRITEABLE_DATA +#if defined(NO_WRITEABLE_DATA) || TRACE_DEFAULT == 0 # define trace TRACE_DEFAULT #else static int trace = TRACE_DEFAULT ; @@ -372,7 +373,7 @@ rotate(list, len, rot) /* do simple left shift by one */ if (rot == 1) { tmp = *list; - memcpy(list, list + 1, len - 1); + memmove(list, list + 1, len - 1); *last = tmp; return; } diff --git a/cpan/Compress-Raw-Zlib/lib/Compress/Raw/Zlib.pm b/cpan/Compress-Raw-Zlib/lib/Compress/Raw/Zlib.pm index 0089b59..59a6100 100644 --- a/cpan/Compress-Raw-Zlib/lib/Compress/Raw/Zlib.pm +++ b/cpan/Compress-Raw-Zlib/lib/Compress/Raw/Zlib.pm @@ -10,7 +10,7 @@ use warnings ; use bytes ; our ($VERSION, $XS_VERSION, @ISA, @EXPORT, %EXPORT_TAGS, @EXPORT_OK, $AUTOLOAD, %DEFLATE_CONSTANTS, @DEFLATE_CONSTANTS); -$VERSION = '2.068_01'; # patched in perl5.git +$VERSION = '2.069'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -1590,7 +1590,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Compress-Raw-Zlib/zlib-src/deflate.c b/cpan/Compress-Raw-Zlib/zlib-src/deflate.c index e001a05..3a28aa1 100644 --- a/cpan/Compress-Raw-Zlib/zlib-src/deflate.c +++ b/cpan/Compress-Raw-Zlib/zlib-src/deflate.c @@ -156,7 +156,7 @@ struct static_tree_desc_s {int dummy;}; /* for buggy compilers */ #endif /* rank Z_BLOCK between Z_NO_FLUSH and Z_PARTIAL_FLUSH */ -#define RANK(f) (((f) << 1) - ((f) > 4 ? 9 : 0)) +#define RANK(f) (((f) * 2) - ((f) > 4 ? 9 : 0)) /* =========================================================================== * Update a hash value with the given input byte diff --git a/cpan/Compress-Raw-Zlib/zlib-src/deflate.h b/cpan/Compress-Raw-Zlib/zlib-src/deflate.h index ce0299e..0ee924e 100644 --- a/cpan/Compress-Raw-Zlib/zlib-src/deflate.h +++ b/cpan/Compress-Raw-Zlib/zlib-src/deflate.h @@ -83,7 +83,7 @@ typedef struct static_tree_desc_s static_tree_desc; typedef struct tree_desc_s { ct_data *dyn_tree; /* the dynamic tree */ int max_code; /* largest code with non zero frequency */ - static_tree_desc *stat_desc; /* the corresponding static tree */ + const static_tree_desc *stat_desc; /* the corresponding static tree */ } FAR tree_desc; typedef ush Pos; diff --git a/cpan/Compress-Raw-Zlib/zlib-src/inflate.c b/cpan/Compress-Raw-Zlib/zlib-src/inflate.c index c8dca0b..c938f49 100644 --- a/cpan/Compress-Raw-Zlib/zlib-src/inflate.c +++ b/cpan/Compress-Raw-Zlib/zlib-src/inflate.c @@ -1490,8 +1490,8 @@ int ZEXPORT inflateUndermine( if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR; state = (struct inflate_state FAR *)strm->state; - state->sane = !subvert; #ifdef INFLATE_ALLOW_INVALID_DISTANCE_TOOFAR_ARRR + state->sane = !subvert; return Z_OK; #else state->sane = 1; diff --git a/cpan/Compress-Raw-Zlib/zlib-src/trees.c b/cpan/Compress-Raw-Zlib/zlib-src/trees.c index 9dbd905..622859a 100644 --- a/cpan/Compress-Raw-Zlib/zlib-src/trees.c +++ b/cpan/Compress-Raw-Zlib/zlib-src/trees.c @@ -122,13 +122,13 @@ struct static_tree_desc_s { int max_length; /* max bit length for the codes */ }; -local static_tree_desc static_l_desc = +local const static_tree_desc static_l_desc = {static_ltree, extra_lbits, LITERALS+1, L_CODES, MAX_BITS}; -local static_tree_desc static_d_desc = +local const static_tree_desc static_d_desc = {static_dtree, extra_dbits, 0, D_CODES, MAX_BITS}; -local static_tree_desc static_bl_desc = +local const static_tree_desc static_bl_desc = {(const ct_data *)0, extra_blbits, 0, BL_CODES, MAX_BL_BITS}; /* =========================================================================== diff --git a/cpan/Devel-PPPort/PPPort_pm.PL b/cpan/Devel-PPPort/PPPort_pm.PL index ff59dfc..0bee17a 100644 --- a/cpan/Devel-PPPort/PPPort_pm.PL +++ b/cpan/Devel-PPPort/PPPort_pm.PL @@ -539,7 +539,7 @@ package Devel::PPPort; use strict; use vars qw($VERSION $data); -$VERSION = '3.31'; +$VERSION = '3.32'; sub _init_data { diff --git a/cpan/Devel-PPPort/parts/inc/misc b/cpan/Devel-PPPort/parts/inc/misc index c39acd0..1cf1e7e 100644 --- a/cpan/Devel-PPPort/parts/inc/misc +++ b/cpan/Devel-PPPort/parts/inc/misc @@ -538,7 +538,7 @@ $_ = "Fred"; ok(&Devel::PPPort::DEFSV(), "Fred"); ok(&Devel::PPPort::UNDERBAR(), "Fred"); -if ($] >= 5.009002) { +if ($] >= 5.009002 && $] < 5.023) { eval q{ no warnings "deprecated"; no if $^V > v5.17.9, warnings => "experimental::lexical_topic"; diff --git a/cpan/Devel-PPPort/soak b/cpan/Devel-PPPort/soak index 5697203..c229ed7 100644 --- a/cpan/Devel-PPPort/soak +++ b/cpan/Devel-PPPort/soak @@ -27,7 +27,7 @@ use File::Find; use List::Util qw(max); use Config; -my $VERSION = '3.31'; +my $VERSION = '3.32'; $| = 1; my %OPT = ( diff --git a/cpan/Devel-PPPort/t/misc.t b/cpan/Devel-PPPort/t/misc.t index 275fa98..5f7f7b6 100644 --- a/cpan/Devel-PPPort/t/misc.t +++ b/cpan/Devel-PPPort/t/misc.t @@ -57,7 +57,7 @@ $_ = "Fred"; ok(&Devel::PPPort::DEFSV(), "Fred"); ok(&Devel::PPPort::UNDERBAR(), "Fred"); -if ($] >= 5.009002) { +if ($] >= 5.009002 && $] < 5.023) { eval q{ no warnings "deprecated"; no if $^V > v5.17.9, warnings => "experimental::lexical_topic"; diff --git a/cpan/Encode/Encode.pm b/cpan/Encode/Encode.pm index 574720e..6a125d4 100644 --- a/cpan/Encode/Encode.pm +++ b/cpan/Encode/Encode.pm @@ -1,10 +1,10 @@ # -# $Id: Encode.pm,v 2.77 2015/09/15 13:53:11 dankogai Exp $ +# $Id: Encode.pm,v 2.78 2015/09/24 02:18:32 dankogai Exp $ # package Encode; use strict; use warnings; -our $VERSION = sprintf "%d.%02d", q$Revision: 2.77 $ =~ /(\d+)/g; +our $VERSION = sprintf "%d.%02d", q$Revision: 2.78 $ =~ /(\d+)/g; use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG}; use XSLoader (); XSLoader::load( __PACKAGE__, $VERSION ); diff --git a/cpan/Encode/Makefile.PL b/cpan/Encode/Makefile.PL index 39e5570..8f73677 100644 --- a/cpan/Encode/Makefile.PL +++ b/cpan/Encode/Makefile.PL @@ -1,5 +1,5 @@ # -# $Id: Makefile.PL,v 2.15 2015/09/15 13:53:27 dankogai Exp dankogai $ +# $Id: Makefile.PL,v 2.16 2015/09/24 02:19:21 dankogai Exp dankogai $ # use 5.007003; use strict; @@ -14,8 +14,10 @@ $ENV{PERL_CORE} ||= $ARGV{PERL_CORE} if $ARGV{PERL_CORE}; my %tables = ( - def_t => ['ascii.ucm', - '8859-1.ucm', # cp1252 is an alias thereof + def_t => [ + 'ascii.ucm', + '8859-1.ucm', + 'cp1252.ucm', 'null.ucm', 'ctrl.ucm', ] diff --git a/cpan/Encode/lib/Encode/Supported.pod b/cpan/Encode/lib/Encode/Supported.pod index 8efa4ff..c731509 100644 --- a/cpan/Encode/lib/Encode/Supported.pod +++ b/cpan/Encode/lib/Encode/Supported.pod @@ -603,7 +603,7 @@ you're doing and unless you really benefit from using C. ISO-IR-165 [RFC1345] VISCII GB 12345 - GB 18030 (**) (see links bellow) + GB 18030 (**) (see links below) EUC-TW (**) are totally valid encodings but not registered at IANA. diff --git a/cpan/File-Path/lib/File/Path.pm b/cpan/File-Path/lib/File/Path.pm index 3ee17bc..36f12cc 100644 --- a/cpan/File-Path/lib/File/Path.pm +++ b/cpan/File-Path/lib/File/Path.pm @@ -18,7 +18,7 @@ BEGIN { use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); -$VERSION = '2.11'; +$VERSION = '2.12'; $VERSION = eval $VERSION; @ISA = qw(Exporter); @EXPORT = qw(mkpath rmtree); @@ -344,7 +344,7 @@ sub _rmtree { : $root; my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ] - or ( _error( $arg, "$root", $root ) and next ROOT_DIR ); + or next ROOT_DIR; if ( -d _ ) { $root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) ) @@ -576,8 +576,7 @@ File::Path - Create or remove directory trees =head1 VERSION -This document describes version 2.09 of File::Path, released -2013-01-17. +This document describes version 2.12 of File::Path. =head1 SYNOPSIS @@ -717,11 +716,14 @@ return value of the function is otherwise identical to make_path(). The C function deletes the given directories and any files and subdirectories they might contain, much like the Unix -command C or the Windows commands C and C. +command C or the Windows commands C and C. The +only exception to the function similarity is C accepts +only directories whereas C 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. +appearing as the last parameter on the call. If an empty string is +passed to C, an error will occur. The functions returns the number of files successfully deleted. @@ -802,9 +804,12 @@ remove_tree(). =item B -The following error handling mechanism is considered -experimental and is subject to change pending feedback from -users. +The following error handling mechanism is consistent throughout all +code paths EXCEPT in cases where the ROOT node is nonexistent. In +version 2.11 the maintainers attempted to rectify this inconsistency +but too many downstream modules encountered problems. In such case, +if you require root node evaluation or error checking prior to calling +C or C, you should take additional precautions. =back @@ -1142,6 +1147,8 @@ Contributors to File::Path, in alphabetical order. =item > +=item Craig A. Berry > + =item Richard Elberger > =item Ryan Yee > diff --git a/cpan/File-Path/t/FilePathTest.pm b/cpan/File-Path/t/FilePathTest.pm new file mode 100644 index 0000000..f9e8289 --- /dev/null +++ b/cpan/File-Path/t/FilePathTest.pm @@ -0,0 +1,112 @@ +package FilePathTest; +use strict; +use warnings; +use base 'Exporter'; +use SelectSaver; +use Cwd; +use File::Spec::Functions; + +our @EXPORT = qw(_run_for_warning _run_for_verbose _basedir + _cannot_delete_safe_mode + _verbose_expected); + +sub _basedir { + return catdir( curdir(), + sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ), + ); + +} + +sub _run_for_warning { + my $coderef = shift; + my $warn = ''; + local $SIG{__WARN__} = sub { $warn .= shift }; + &$coderef; + return $warn; +} + +sub _run_for_verbose { + my $coderef = shift; + my $stdout = ''; + { + my $guard = SelectSaver->new(_ref_to_fh(\$stdout)); + &$coderef; + } + return $stdout; +} + +sub _ref_to_fh { + my $output = shift; + open my $fh, '>', $output; + return $fh; +} + +# Whether a directory can be deleted without modifying permissions varies +# by platform and by current privileges, so we really have to do the same +# check the module does in safe mode to determine that. + +sub _cannot_delete_safe_mode { + my $path = shift; + return $^O eq 'VMS' + ? !&VMS::Filespec::candelete($path) + : !-w $path; +} + +# What verbose mode reports depends on what it can do in safe mode. +# Plus on VMS, mkpath may report what it's operating on in a +# different format from the format of the path passed to it. + +sub _verbose_expected { + my ($function, $path, $safe_mode, $base) = @_; + my $expected; + + if ($function =~ m/^(mkpath|make_path)$/) { + # On VMS, mkpath reports in Unix format. Maddeningly, it + # reports the top-level directory without a trailing slash + # and everything else with. + if ($^O eq 'VMS') { + $path = VMS::Filespec::unixify($path); + $path =~ s/\/$// if defined $base && $base; + } + $expected = "mkdir $path\n"; + } + elsif ($function =~ m/^(rmtree|remove_tree)$/) { + # N.B. Directories must still/already exist for this to work. + $expected = $safe_mode && _cannot_delete_safe_mode($path) + ? "skipped $path\n" + : "rmdir $path\n"; + } + elsif ($function =~ m/^(unlink)$/) { + $expected = "unlink $path\n"; + $expected =~ s/\n\z/\.\n/ if $^O eq 'VMS'; + } + else { + die "Unknown function $function in _verbose_expected"; + } + return $expected; +} + +BEGIN { + if ($] < 5.008000) { + eval qq{#line @{[__LINE__+1]} "@{[__FILE__]}"\n} . <<'END' or die $@; + no warnings 'redefine'; + use Symbol (); + + sub _ref_to_fh { + my $output = shift; + my $fh = Symbol::gensym(); + tie *$fh, 'StringIO', $output; + return $fh; + } + + package StringIO; + sub TIEHANDLE { bless [ $_[1] ], $_[0] } + sub CLOSE { @{$_[0]} = (); 1 } + sub PRINT { ${ $_[0][0] } .= $_[1] } + sub PRINTF { ${ $_[0][0] } .= sprintf $_[1], @_[2..$#_] } + 1; +END + } +} + +1; diff --git a/cpan/File-Path/t/Path.t b/cpan/File-Path/t/Path.t index ea4d2b5..5644f57 100644 --- a/cpan/File-Path/t/Path.t +++ b/cpan/File-Path/t/Path.t @@ -3,22 +3,18 @@ use strict; -use Test::More tests => 159; +use Test::More tests => 127; use Config; use Fcntl ':mode'; +use lib 't/'; +use FilePathTest; BEGIN { - # 1 use_ok('Cwd'); - # 2 use_ok('File::Path', qw(rmtree mkpath make_path remove_tree)); - # 3 use_ok('File::Spec::Functions'); } -eval "use Test::Output"; -my $has_Test_Output = $@ ? 0 : 1; - my $Is_VMS = $^O eq 'VMS'; # first check for stupid permissions second for full, so we clean up @@ -29,13 +25,12 @@ for my $perm (0111,0777) { chmod $perm, "mhx", $path; my $oct = sprintf('0%o', $perm); - # 4 + ok(-d "mhx", "mkdir parent dir $oct"); - # 5 ok(-d $path, "mkdir child dir $oct"); rmtree("mhx"); - # 6 + ok(! -e "mhx", "mhx does not exist $oct"); } @@ -57,7 +52,6 @@ my @dir = ( # create them my @created = mkpath([@dir]); -# 7 is(scalar(@created), 7, "created list of directories"); # pray for no race conditions blowing them out from under us @@ -81,12 +75,10 @@ SKIP: { skip "cannot remove a file we failed to create", 1 unless $file_count == 1; my $count = rmtree($file_name); -# 8 is($count, 1, "rmtree'ed a file"); } @created = mkpath(''); -# 9 is(scalar(@created), 0, "Can't create a directory named ''"); my $dir; @@ -112,16 +104,14 @@ sub count { open my $f, '>', 'foo.dat'; close $f; my $before = count(curdir()); -# 10 cmp_ok($before, '>', 0, "baseline $before"); gisle('1st', 1); -# 11 is(count(curdir()), $before + 1, "first after $before"); $before = count(curdir()); gisle('2nd', 1); -# 12 + is(count(curdir()), $before + 1, "second after $before"); chdir updir(); @@ -134,13 +124,13 @@ sub count { open my $f, '>', 'foo.dat'; close $f; my $before = count(curdir()); -# 13 + cmp_ok($before, '>', 0, "ARGV $before"); { local @ARGV = (1); mkpath('3rd', !shift, 0755); } -# 14 + is(count(curdir()), $before + 1, "third after $before"); $before = count(curdir()); @@ -148,7 +138,7 @@ sub count { local @ARGV = (1); mkpath('4th', !shift, 0755); } -# 15 + is(count(curdir()), $before + 1, "fourth after $before"); chdir updir(); @@ -169,21 +159,21 @@ SKIP: { rmtree($dir, {error => \$error}); my $nr_err = @$error; -# 16 + is($nr_err, 1, "ancestor error"); if ($nr_err) { my ($file, $message) = each %{$error->[0]}; -# 17 + is($file, $dir, "ancestor named"); my $ortho_dir = $^O eq 'MSWin32' ? File::Path::_slash_lc($dir2) : $dir2; $^O eq 'MSWin32' and $message =~ s/\A(cannot remove path when cwd is )(.*)\Z/$1 . File::Path::_slash_lc($2)/e; -# 18 + is($message, "cannot remove path when cwd is $ortho_dir", "ancestor reason"); -# 19 + ok(-d $dir2, "child not removed"); -# 20 + ok(-d $dir, "ancestor not removed"); } else { @@ -194,18 +184,18 @@ SKIP: { } chdir $cwd; rmtree($dir); -# 21 + ok(!(-d $dir), "ancestor now removed"); }; my $count = rmtree({error => \$error}); -# 22 + is( $count, 0, 'rmtree of nothing, count of zero' ); -# 23 + is( scalar(@$error), 0, 'no diagnostic captured' ); @created = mkpath($tmp_base, 0); -# 24 + is(scalar(@created), 0, "skipped making existing directories (old style 1)") or diag("unexpectedly recreated @created"); @@ -213,13 +203,13 @@ $dir = catdir($tmp_base,'C'); # mkpath returns unix syntax filespecs on VMS $dir = VMS::Filespec::unixify($dir) if $Is_VMS; @created = make_path($tmp_base, $dir); -# 25 + is(scalar(@created), 1, "created directory (new style 1)"); -# 26 + is($created[0], $dir, "created directory (new style 1) cross-check"); @created = mkpath($tmp_base, 0, 0700); -# 27 + is(scalar(@created), 0, "skipped making existing directories (old style 2)") or diag("unexpectedly recreated @created"); @@ -227,34 +217,35 @@ $dir2 = catdir($tmp_base,'D'); # mkpath returns unix syntax filespecs on VMS $dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS; @created = make_path($tmp_base, $dir, $dir2); -# 28 + is(scalar(@created), 1, "created directory (new style 2)"); -# 29 + is($created[0], $dir2, "created directory (new style 2) cross-check"); $count = rmtree($dir, 0); -# 30 + is($count, 1, "removed directory unsafe mode"); +my $expected_count = _cannot_delete_safe_mode($dir2) ? 0 : 1; + $count = rmtree($dir2, 0, 1); -my $removed = $Is_VMS ? 0 : 1; -# 31 -is($count, $removed, "removed directory safe mode"); + +is($count, $expected_count, "removed directory safe mode"); # mkdir foo ./E/../Y # Y should exist # existence of E is neither here nor there $dir = catdir($tmp_base, 'E', updir(), 'Y'); @created =mkpath($dir); -# 32 + cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of .."); -# 33 + cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of .."); -# 34 + ok( -d catdir($tmp_base, 'Y'), "directory after parent" ); @created = make_path(catdir(curdir(), $tmp_base)); -# 35 + is(scalar(@created), 0, "nothing created") or diag(@created); @@ -269,14 +260,14 @@ rmtree( $dir, $dir2, } ); -# 36 + is(scalar(@$error), 0, "no errors unlinking a and z"); -# 37 + is(scalar(@$list), 4, "list contains 4 elements") or diag("@$list"); -# 38 + ok(-d $dir, "dir a still exists"); -# 39 + ok(-d $dir2, "dir z still exists"); $dir = catdir($tmp_base,'F'); @@ -284,38 +275,38 @@ $dir = catdir($tmp_base,'F'); $dir = VMS::Filespec::unixify($dir) if $Is_VMS; @created = mkpath($dir, undef, 0770); -# 40 + is(scalar(@created), 1, "created directory (old style 2 verbose undef)"); -# 41 + is($created[0], $dir, "created directory (old style 2 verbose undef) cross-check"); -# 42 + is(rmtree($dir, undef, 0), 1, "removed directory 2 verbose undef"); @created = mkpath($dir, undef); -# 43 + is(scalar(@created), 1, "created directory (old style 2a verbose undef)"); -# 44 + is($created[0], $dir, "created directory (old style 2a verbose undef) cross-check"); -# 45 + is(rmtree($dir, undef), 1, "removed directory 2a verbose undef"); @created = mkpath($dir, 0, undef); -# 46 + is(scalar(@created), 1, "created directory (old style 3 mode undef)"); -# 47 + is($created[0], $dir, "created directory (old style 3 mode undef) cross-check"); -# 48 + is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef"); $dir = catdir($tmp_base,'G'); $dir = VMS::Filespec::unixify($dir) if $Is_VMS; @created = mkpath($dir, undef, 0200); -# 49 + is(scalar(@created), 1, "created write-only dir"); -# 50 + is($created[0], $dir, "created write-only directory cross-check"); -# 51 + is(rmtree($dir), 1, "removed write-only dir"); # borderline new-style heuristics @@ -330,46 +321,44 @@ $dir = catdir('a', 'd1'); $dir2 = catdir('a', 'd2'); @created = make_path( $dir, 0, $dir2 ); -# 52 + is(scalar @created, 3, 'new-style 3 dirs created'); $count = remove_tree( $dir, 0, $dir2, ); -# 53 + is($count, 3, 'new-style 3 dirs removed'); @created = make_path( $dir, $dir2, 1 ); -# 54 + is(scalar @created, 3, 'new-style 3 dirs created (redux)'); $count = remove_tree( $dir, $dir2, 1 ); -# 55 + is($count, 3, 'new-style 3 dirs removed (redux)'); @created = make_path( $dir, $dir2 ); -# 56 + is(scalar @created, 2, 'new-style 2 dirs created'); $count = remove_tree( $dir, $dir2 ); -# 57 + is($count, 2, 'new-style 2 dirs removed'); $dir = catdir("a\nb", 'd1'); $dir2 = catdir("a\nb", 'd2'); - - SKIP: { # Better to search for *nix derivatives? # Not sure what else doesn't support newline in paths - skip "This is a MSWin32 platform", 2 - if $^O eq 'MSWin32'; + skip "$^O doesn't allow newline in paths", 2 + if $^O =~ m/^(MSWin32|VMS)$/; @created = make_path( $dir, $dir2 ); -# 58 + is(scalar @created, 3, 'new-style 3 dirs created in parent with newline'); $count = remove_tree( $dir, $dir2 ); -# 59 + is($count, 2, 'new-style 2 dirs removed in parent with newline'); } @@ -381,25 +370,6 @@ else { } SKIP: { - skip "This is not a MSWin32 platform", 3 - unless $^O eq 'MSWin32'; - - my $UNC_path = catdir(getcwd(), $tmp_base, 'uncdir'); - #dont compute a SMB path with $ENV{COMPUTERNAME}, since SMB may be turned off - #firewalled, disabled, blocked, or no NICs are on and there the PC has no - #working TCPIP stack, \\?\ will always work - $UNC_path = '\\\\?\\'.$UNC_path; -# 60 - is(mkpath($UNC_path), 1, 'mkpath on Win32 UNC path returns made 1 dir'); -# 61 - ok(-d $UNC_path, 'mkpath on Win32 UNC path made dir'); - - my $removed = rmtree($UNC_path); -# 62 - cmp_ok($removed, '>', 0, "removed $removed entries from $UNC_path"); -} - -SKIP: { # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319 skip "Don't need Force_Writeable semantics on $^O", 6 if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2); @@ -407,10 +377,10 @@ SKIP: { $dir = 'bug487319'; $dir2 = 'bug487319-symlink'; @created = make_path($dir, {mask => 0700}); -# 63 + is( scalar @created, 1, 'bug 487319 setup' ); symlink($dir, $dir2); -# 64 + ok(-e $dir2, "debian bug 487319 setup symlink") or diag($dir2); chmod 0500, $dir; @@ -418,7 +388,7 @@ SKIP: { remove_tree($dir2); my $mask = (stat $dir)[2]; -# 65 + is( $mask, $mask_initial, 'mask of symlink target dir unchanged (debian bug 487319)'); # now try a file @@ -427,19 +397,19 @@ SKIP: { my $file2 = 'bug487319-file-symlink'; open my $out, '>', $file; close $out; -# 66 + ok(-e $file, 'file exists'); chmod 0500, $file; $mask_initial = (stat $file)[2]; symlink($file, $file2); -# 67 + ok(-e $file2, 'file2 exists'); remove_tree($file2); $mask = (stat $file)[2]; -# 68 + is( $mask, $mask_initial, 'mask of symlink target file unchanged (debian bug 487319)'); remove_tree($dir); @@ -468,53 +438,6 @@ SKIP: { or diag(@created); } -my $extra = catdir(curdir(), qw(EXTRA 1 a)); - -SKIP: { - skip "extra scenarios not set up, see eg/setup-extra-tests", 14 - unless -e $extra; - skip "Symlinks not available", 14 unless $Config{d_symlink}; - - my ($list, $err); - $dir = catdir( 'EXTRA', '1' ); - rmtree( $dir, {result => \$list, error => \$err} ); - is(scalar(@$list), 2, "extra dir $dir removed"); - is(scalar(@$err), 1, "one error encountered"); - - $dir = catdir( 'EXTRA', '3', 'N' ); - rmtree( $dir, {result => \$list, error => \$err} ); - is( @$list, 1, q{remove a symlinked dir} ); - is( @$err, 0, q{with no errors} ); - - $dir = catdir('EXTRA', '3', 'S'); - rmtree($dir, {error => \$error}); - is( scalar(@$error), 1, 'one error for an unreadable dir' ); - eval { ($file, $message) = each %{$error->[0]}}; - is( $file, $dir, 'unreadable dir reported in error' ) - or diag($message); - - $dir = catdir('EXTRA', '3', 'T'); - rmtree($dir, {error => \$error}); - is( scalar(@$error), 1, 'one error for an unreadable dir T' ); - eval { ($file, $message) = each %{$error->[0]}}; - is( $file, $dir, 'unreadable dir reported in error T' ); - - $dir = catdir( 'EXTRA', '4' ); - rmtree($dir, {result => \$list, error => \$err} ); - is( scalar(@$list), 0, q{don't follow a symlinked dir} ); - is( scalar(@$err), 2, q{two errors when removing a symlink in r/o dir} ); - eval { ($file, $message) = each %{$err->[0]} }; - is( $file, $dir, 'symlink reported in error' ); - - $dir = catdir('EXTRA', '3', 'U'); - $dir2 = catdir('EXTRA', '3', 'V'); - rmtree($dir, $dir2, {verbose => 0, error => \$err, result => \$list}); - is( scalar(@$list), 1, q{deleted 1 out of 2 directories} ); - is( scalar(@$error), 1, q{left behind 1 out of 2 directories} ); - eval { ($file, $message) = each %{$err->[0]} }; - is( $file, $dir, 'first dir reported in error' ); -} - { $dir = catdir($tmp_base, 'ZZ'); @created = mkpath($dir); @@ -527,7 +450,9 @@ SKIP: { SKIP : { my $skip_count = 19; - #this test will fail on Windows, as per: http://perldoc.perl.org/perlport.html#chmod + # 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'; my $mode; @@ -544,6 +469,9 @@ SKIP : { foreach (@inputs) { $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); @created = mkpath($dir, {chmod => $input}); $mode = (stat($dir))[2]; $octal_mode = S_IMODE($mode); @@ -553,267 +481,139 @@ SKIP : { } } -SKIP: { - my $skip_count = 8; # DRY - skip "getpwent() not implemented on $^O", $skip_count - unless $Config{d_getpwent}; - skip "getgrent() not implemented on $^O", $skip_count - unless $Config{d_getgrent}; - skip 'not running as root', $skip_count - unless $< == 0; - skip "darwin's nobody and nogroup are -1", $skip_count - if $^O eq 'darwin'; - - my $dir_stem = $dir = catdir($tmp_base, 'owned-by'); - - # find the highest uid ('nobody' or similar) - my $max_uid = 0; - my $max_user = undef; - while (my @u = getpwent()) { - if ($max_uid < $u[2]) { - $max_uid = $u[2]; - $max_user = $u[0]; - } - } - skip 'getpwent() appears to be insane', $skip_count - unless $max_uid > 0; - - # find the highest gid ('nogroup' or similar) - my $max_gid = 0; - my $max_group = undef; - while (my @g = getgrent()) { - if ($max_gid < $g[2]) { - $max_gid = $g[2]; - $max_group = $g[0]; - } - } - skip 'getgrent() appears to be insane', $skip_count - unless $max_gid > 0; - - $dir = catdir($dir_stem, 'aaa'); - @created = make_path($dir, {owner => $max_user}); - is(scalar(@created), 2, "created a directory owned by $max_user..."); - my $dir_uid = (stat $created[0])[4]; - is($dir_uid, $max_uid, "... owned by $max_uid"); - - $dir = catdir($dir_stem, 'aab'); - @created = make_path($dir, {group => $max_group}); - is(scalar(@created), 1, "created a directory owned by group $max_group..."); - my $dir_gid = (stat $created[0])[5]; - is($dir_gid, $max_gid, "... owned by group $max_gid"); - - $dir = catdir($dir_stem, 'aac'); - @created = make_path($dir, {user => $max_user, group => $max_group}); - is(scalar(@created), 1, "created a directory owned by $max_user:$max_group..."); - ($dir_uid, $dir_gid) = (stat $created[0])[4,5]; - is($dir_uid, $max_uid, "... owned by $max_uid"); - is($dir_gid, $max_gid, "... owned by group $max_gid"); - - SKIP: { - skip 'Test::Output not available', 1 - unless $has_Test_Output; - - # 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'); - stderr_like( - sub {make_path($dir, {user => $max_user, group => $max_group})}, - 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..." - ); - } -} +my $dir_base = catdir($tmp_base,'output'); +my $dir_a = catdir($dir_base, 'A'); +my $dir_b = catdir($dir_base, 'B'); -SKIP: { - skip 'Test::Output not available', 18 - unless $has_Test_Output; - - SKIP: { - $dir = catdir('EXTRA', '3'); - skip "extra scenarios not set up, see eg/setup-extra-tests", 3 - unless -e $dir; - - $dir = catdir('EXTRA', '3', 'U'); - stderr_like( - sub {rmtree($dir, {verbose => 0})}, - qr{\Acannot make child directory read-write-exec for [^:]+: .* at \S+ line \d+}, - q(rmtree can't chdir into root dir) - ); +is(_run_for_verbose(sub {@created = mkpath($dir_a, 1)}), + _verbose_expected('mkpath', $dir_base, 0, 1) + . _verbose_expected('mkpath', $dir_a, 0), + 'mkpath verbose (old style 1)' +); - $dir = catdir('EXTRA', '3'); - stderr_like( - sub {rmtree($dir, {})}, - qr{\Acannot make child directory read-write-exec for [^:]+: .* at (\S+) line (\d+) -cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 -cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 -cannot remove directory for [^:]+: .* at \1 line \2}, - 'rmtree with file owned by root' - ); +is(_run_for_verbose(sub {@created = mkpath([$dir_b], 1)}), + _verbose_expected('mkpath', $dir_b, 0), + 'mkpath verbose (old style 2)' +); - stderr_like( - sub {rmtree('EXTRA', {})}, - qr{\Acannot remove directory for [^:]+: .* at (\S+) line (\d+) -cannot remove directory for [^:]+: .* at \1 line \2 -cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 -cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 -cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 -cannot remove directory for [^:]+: .* at \1 line \2 -cannot unlink file for [^:]+: .* at \1 line \2 -cannot restore permissions to \d+ for [^:]+: .* at \1 line \2 -cannot make child directory read-write-exec for [^:]+: .* at \1 line \2 -cannot remove directory for [^:]+: .* at \1 line \2}, - 'rmtree with insufficient privileges' - ); - } +my $verbose_expected; - my $base = catdir($tmp_base,'output'); - $dir = catdir($base,'A'); - $dir2 = catdir($base,'B'); +# Must determine expectations while directories still exist. +$verbose_expected = _verbose_expected('rmtree', $dir_a, 1) + . _verbose_expected('rmtree', $dir_b, 1); - stderr_like( - sub { rmtree( undef, 1 ) }, - qr/\ANo root path\(s\) specified\b/, - "rmtree of nothing carps sensibly" - ); +is(_run_for_verbose(sub {$count = rmtree([$dir_a, $dir_b], 1, 1)}), + $verbose_expected, + 'rmtree verbose (old style)' +); - stderr_like( - sub { rmtree( '', 1 ) }, - qr/\ANo root path\(s\) specified\b/, - "rmtree of empty dir carps sensibly" - ); +# In case we didn't delete them in safe mode. +rmtree($dir_a) if -d $dir_a; +rmtree($dir_b) if -d $dir_b; - stderr_is( sub { make_path() }, '', "make_path no args does not carp" ); - stderr_is( sub { remove_tree() }, '', "remove_tree no args does not carp" ); - stderr_is( sub { mkpath() }, '', "mkpath no args does not carp" ); +is(_run_for_verbose(sub {@created = mkpath( $dir_a, + {verbose => 1, mask => 0750})}), + _verbose_expected('mkpath', $dir_a, 0), + 'mkpath verbose (new style 1)' +); - stdout_is( - sub {@created = mkpath($dir, 1)}, - "mkdir $base\nmkdir $dir\n", - 'mkpath verbose (old style 1)' - ); +is(_run_for_verbose(sub {@created = mkpath($dir_b, 1, 0771)}), + _verbose_expected('mkpath', $dir_b, 0), + 'mkpath verbose (new style 2)' +); - stdout_is( - sub {@created = mkpath([$dir2], 1)}, - "mkdir $dir2\n", - 'mkpath verbose (old style 2)' - ); +$verbose_expected = _verbose_expected('rmtree', $dir_a, 1) + . _verbose_expected('rmtree', $dir_b, 1); - stdout_is( - sub {$count = rmtree([$dir, $dir2], 1, 1)}, - "rmdir $dir\nrmdir $dir2\n", - 'rmtree verbose (old style)' - ); +is(_run_for_verbose(sub {$count = rmtree([$dir_a, $dir_b], 1, 1)}), + $verbose_expected, + 'again: rmtree verbose (old style)' +); - stdout_is( - sub {@created = mkpath($dir, {verbose => 1, mask => 0750})}, - "mkdir $dir\n", - 'mkpath verbose (new style 1)' - ); +rmtree($dir_a) if -d $dir_a; +rmtree($dir_b) if -d $dir_b; - stdout_is( - sub {@created = mkpath($dir2, 1, 0771)}, - "mkdir $dir2\n", - 'mkpath verbose (new style 2)' - ); +is(_run_for_verbose(sub {@created = make_path( $dir_a, $dir_b, + {verbose => 1, mode => 0711});}), + _verbose_expected('make_path', $dir_a, 1) + . _verbose_expected('make_path', $dir_b, 1), + 'make_path verbose with final hashref' +); - stdout_is( - sub {$count = rmtree([$dir, $dir2], 1, 1)}, - "rmdir $dir\nrmdir $dir2\n", - 'again: rmtree verbose (old style)' - ); +$verbose_expected = _verbose_expected('remove_tree', $dir_a, 0) + . _verbose_expected('remove_tree', $dir_b, 0); - stdout_is( - sub { - @created = make_path( - $dir, - $dir2, - { verbose => 1, mode => 0711 } - ); - }, - "mkdir $dir\nmkdir $dir2\n", - 'make_path verbose with final hashref' - ); +is(_run_for_verbose(sub {@created = remove_tree( $dir_a, $dir_b, + {verbose => 1});}), + $verbose_expected, + 'remove_tree verbose with final hashref' +); + +rmtree($dir_a) if -d $dir_a; +rmtree($dir_b) if -d $dir_b; + +# Have to re-create these 2 directories so that next block is not skipped. +@created = make_path( + $dir_a, + $dir_b, + { mode => 0711 } +); +is(@created, 2, "2 directories created"); + +SKIP: { + $file = catfile($dir_b, "file"); + skip "Cannot create $file", 2 unless open OUT, "> $file"; + print OUT "test file, safe to delete\n", scalar(localtime), "\n"; + close OUT; + + $verbose_expected = _verbose_expected('rmtree', $dir_a, 1) + . _verbose_expected('unlink', $file, 0) + . _verbose_expected('rmtree', $dir_b, 1); + + ok(-e $file, "file created in directory"); - # { - # local $@; - # eval { - # @created = make_path( - # $dir, - # $dir2, - # { verbose => 1, mode => 0711, foo => 1, bar => 1 } - # ); - # }; - # like($@, - # qr/Unrecognized option\(s\) passed to make_path\(\):.*?bar.*?foo/, - # 'make_path with final hashref failed due to unrecognized options' - # ); - # } - # - # { - # local $@; - # eval { - # @created = remove_tree( - # $dir, - # $dir2, - # { verbose => 1, foo => 1, bar => 1 } - # ); - # }; - # like($@, - # qr/Unrecognized option\(s\) passed to remove_tree\(\):.*?bar.*?foo/, - # 'remove_tree with final hashref failed due to unrecognized options' - # ); - # } - - stdout_is( - sub { - @created = remove_tree( - $dir, - $dir2, - { verbose => 1 } - ); - }, - "rmdir $dir\nrmdir $dir2\n", - 'remove_tree verbose with final hashref' + is(_run_for_verbose(sub {$count = rmtree( $dir_a, $dir_b, + {verbose => 1, safe => 1})}), + $verbose_expected, + 'rmtree safe verbose (new style)' ); + rmtree($dir_a) if -d $dir_a; + rmtree($dir_b) if -d $dir_b; +} - SKIP: { - $file = catdir($dir2, "file"); - skip "Cannot create $file", 2 unless open OUT, "> $file"; - print OUT "test file, safe to delete\n", scalar(localtime), "\n"; - close OUT; +{ + my $base = catdir( $tmp_base, 'output2'); + my $dir = catdir( $base, 'A'); + my $dir2 = catdir( $base, 'B'); - ok(-e $file, "file created in directory"); + { + my $warn; + $SIG{__WARN__} = sub { $warn = shift }; - stdout_is( - sub {$count = rmtree($dir, $dir2, {verbose => 1, safe => 1})}, - "rmdir $dir\nunlink $file\nrmdir $dir2\n", - 'rmtree safe verbose (new style)' + my @created = make_path( + $dir, + $dir2, + { mode => 0711, foo => 1, bar => 1 } + ); + like($warn, + qr/Unrecognized option\(s\) passed to make_path\(\):.*?bar.*?foo/, + 'make_path with final hashref warned due to unrecognized options' ); } -} -SKIP: { - skip "extra scenarios not set up, see eg/setup-extra-tests", 11 - unless -d catdir(qw(EXTRA 1)); - - rmtree 'EXTRA', {safe => 0, error => \$error}; - is( scalar(@$error), 10, 'seven deadly sins' ); # well there used to be 7 - - rmtree 'EXTRA', {safe => 1, error => \$error}; - is( scalar(@$error), 9, 'safe is better' ); - for (@$error) { - ($file, $message) = each %$_; - if ($file =~ /[123]\z/) { - is(index($message, 'cannot remove directory: '), 0, "failed to remove $file with rmdir") - or diag($message); - } - else { - like($message, qr(\Acannot (?:restore permissions to \d+|chdir to child|unlink file): ), "failed to remove $file with unlink") - or diag($message) - } + { + my $warn; + $SIG{__WARN__} = sub { $warn = shift }; + + 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' + ); } } @@ -832,14 +632,17 @@ SKIP: { ok(mkpath($xx), "make $xx"); ok(chdir($xx), "... and chdir $xx"); END { - ok(chdir($p), "... now chdir $p"); - ok(rmtree($xx), "... and finally rmtree $xx"); +# ok(chdir($p), "... now chdir $p"); +# ok(rmtree($xx), "... and finally rmtree $xx"); + chdir($p); + rmtree($xx); } # create and delete directory my $px = catdir($p, $x); ok(mkpath($px), 'create and delete directory 2.07'); ok(rmtree($px), '.. rmtree fails in File-Path-2.07'); + chdir updir(); } my $windows_dir = 'C:\Path\To\Dir'; @@ -849,3 +652,80 @@ is( $expect, "Windows path unixified as expected" ); + +{ + my ($x, $message, $object, $expect, $rv, $arg, $error); + my ($k, $v, $second_error, $third_error); + local $! = 2; + $x = $!; + + $message = 'message in a bottle'; + $object = '/path/to/glory'; + $expect = "$message for $object: $x"; + $rv = _run_for_warning( sub { + File::Path::_error( + {}, + $message, + $object + ); + } ); + like($rv, qr/^$expect/, + "no \$arg->{error}: defined 2nd and 3rd args: got expected error message"); + + $object = undef; + $expect = "$message: $x"; + $rv = _run_for_warning( sub { + File::Path::_error( + {}, + $message, + $object + ); + } ); + like($rv, qr/^$expect/, + "no \$arg->{error}: defined 2nd arg; undefined 3rd arg: got expected error message"); + + $message = 'message in a bottle'; + $object = undef; + $expect = "$message: $x"; + $arg = { error => \$error }; + File::Path::_error( + $arg, + $message, + $object + ); + is(ref($error->[0]), 'HASH', + "first element of array inside \$error is hashref"); + ($k, $v) = %{$error->[0]}; + is($k, '', 'key of hash is empty string, since 3rd arg was undef'); + is($v, $expect, "value of hash is 2nd arg: $message"); + + $message = ''; + $object = '/path/to/glory'; + $expect = "$message: $x"; + $arg = { error => \$second_error }; + File::Path::_error( + $arg, + $message, + $object + ); + is(ref($second_error->[0]), 'HASH', + "first element of array inside \$second_error is hashref"); + ($k, $v) = %{$second_error->[0]}; + is($k, $object, "key of hash is '$object', since 3rd arg was defined"); + is($v, $expect, "value of hash is 2nd arg: $message"); + + $message = ''; + $object = undef; + $expect = "$message: $x"; + $arg = { error => \$third_error }; + File::Path::_error( + $arg, + $message, + $object + ); + is(ref($third_error->[0]), 'HASH', + "first element of array inside \$third_error is hashref"); + ($k, $v) = %{$third_error->[0]}; + is($k, '', "key of hash is empty string, since 3rd arg was undef"); + is($v, $expect, "value of hash is 2nd arg: $message"); +} diff --git a/cpan/File-Path/t/Path_root.t b/cpan/File-Path/t/Path_root.t new file mode 100644 index 0000000..36aeb16 --- /dev/null +++ b/cpan/File-Path/t/Path_root.t @@ -0,0 +1,123 @@ +use strict; +use Test::More; +use Config; +use lib 't/'; +use FilePathTest; +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; + +my $pwent = max_u(); +my $grent = max_g(); +my ( $max_uid, $max_user ) = @{ $pwent }; +my ( $max_gid, $max_group ) = @{ $grent }; + +my $tmp_base = catdir( + curdir(), + sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ), +); + +# invent some names +my @dir = ( + catdir($tmp_base, qw(a b)), + catdir($tmp_base, qw(a c)), + catdir($tmp_base, qw(z b)), + catdir($tmp_base, qw(z c)), +); + +# create them +my @created = mkpath([@dir]); + +my $dir; +my $dir2; + +my $dir_stem = $dir = catdir($tmp_base, 'owned-by'); + +$dir = catdir($dir_stem, 'aaa'); +@created = make_path($dir, {owner => $max_user}); +is(scalar(@created), 2, "created a directory owned by $max_user..."); + +my $dir_uid = (stat $created[0])[4]; +is($dir_uid, $max_uid, "... owned by $max_uid"); + +$dir = catdir($dir_stem, 'aab'); +@created = make_path($dir, {group => $max_group}); +is(scalar(@created), 1, "created a directory owned by group $max_group..."); + +my $dir_gid = (stat $created[0])[5]; +is($dir_gid, $max_gid, "... owned by group $max_gid"); + +$dir = catdir($dir_stem, 'aac'); +@created = make_path( $dir, { user => $max_user, + group => $max_group}); +is(scalar(@created), 1, "created a directory owned by $max_user:$max_group..."); + +($dir_uid, $dir_gid) = (stat $created[0])[4,5]; +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 } ) } ); + 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..." + ); +} + +sub max_u { + # find the highest uid ('nobody' or similar) + my $max_uid = 0; + my $max_user = undef; + while (my @u = getpwent()) { + if ($max_uid < $u[2]) { + $max_uid = $u[2]; + $max_user = $u[0]; + } + } + setpwent(); # in case we want to run again later + return [ $max_uid, $max_user ]; +} + +sub max_g { + # find the highest gid ('nogroup' or similar) + my $max_gid = 0; + my $max_group = undef; + while ( my @g = getgrent() ) { + print Dumper @g; + if ($max_gid < $g[2]) { + $max_gid = $g[2]; + $max_group = $g[0]; + } + } + setgrent(); # in case we want to run again later + return [ $max_gid, $max_group ]; +} + +sub prereq { + return "getpwent() not implemented on $^O" unless $Config{d_getpwent}; + return "getgrent() not implemented on $^O" unless $Config{d_getgrent}; + return "not running as root" unless $< == 0; + return "darwin's nobody and nogroup are -1 or -2" if $^O eq 'darwin'; + + my $pwent = max_u(); + my $grent = max_g(); + my ( $max_uid, $max_user ) = @{ $pwent }; + my ( $max_gid, $max_group ) = @{ $grent }; + + return "getpwent() appears to be insane" unless $max_uid > 0; + return "getgrent() appears to be insane" unless $max_gid > 0; + return undef; +} diff --git a/cpan/File-Path/t/Path_win32.t b/cpan/File-Path/t/Path_win32.t new file mode 100644 index 0000000..c2b2f28 --- /dev/null +++ b/cpan/File-Path/t/Path_win32.t @@ -0,0 +1,29 @@ +use strict; +use Test::More; +use lib 't/'; +use FilePathTest; +use File::Path; +use Cwd; +use File::Spec::Functions; + +plan skip_all => 'not win32' unless $^O eq 'MSWin32'; +plan tests => 3; + +my $tmp_base = catdir( + curdir(), + sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ), +); + +my $UNC_path = catdir(getcwd(), $tmp_base, 'uncdir'); +#dont compute a SMB path with $ENV{COMPUTERNAME}, since SMB may be turned off +#firewalled, disabled, blocked, or no NICs are on and there the PC has no +#working TCPIP stack, \\?\ will always work +$UNC_path = '\\\\?\\'.$UNC_path; + +is(mkpath($UNC_path), 2, 'mkpath on Win32 UNC path returns made 2 dir - base and uncdir'); + +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"); diff --git a/cpan/IO-Compress/Makefile.PL b/cpan/IO-Compress/Makefile.PL index 344169a..a302691 100644 --- a/cpan/IO-Compress/Makefile.PL +++ b/cpan/IO-Compress/Makefile.PL @@ -3,7 +3,7 @@ use strict ; require 5.006 ; -$::VERSION = '2.068' ; +$::VERSION = '2.069' ; use private::MakeUtil; use ExtUtils::MakeMaker 5.16 ; diff --git a/cpan/IO-Compress/lib/Compress/Zlib.pm b/cpan/IO-Compress/lib/Compress/Zlib.pm index d197a34..36070c7 100644 --- a/cpan/IO-Compress/lib/Compress/Zlib.pm +++ b/cpan/IO-Compress/lib/Compress/Zlib.pm @@ -7,17 +7,17 @@ use Carp ; use IO::Handle ; use Scalar::Util qw(dualvar); -use IO::Compress::Base::Common 2.068 ; -use Compress::Raw::Zlib 2.068 ; -use IO::Compress::Gzip 2.068 ; -use IO::Uncompress::Gunzip 2.068 ; +use IO::Compress::Base::Common 2.069 ; +use Compress::Raw::Zlib 2.069 ; +use IO::Compress::Gzip 2.069 ; +use IO::Uncompress::Gunzip 2.069 ; use strict ; use warnings ; use bytes ; our ($VERSION, $XS_VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); -$VERSION = '2.068'; +$VERSION = '2.069'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -461,7 +461,7 @@ sub inflate package Compress::Zlib ; -use IO::Compress::Gzip::Constants 2.068 ; +use IO::Compress::Gzip::Constants 2.069 ; sub memGzip($) { @@ -1500,7 +1500,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 1995-2014 Paul Marquess. All rights reserved. +Copyright (c) 1995-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm b/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm index 096c753..74757a9 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm @@ -4,12 +4,12 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.068 qw(:Status); +use IO::Compress::Base::Common 2.069 qw(:Status); -use Compress::Raw::Bzip2 2.068 ; +use Compress::Raw::Bzip2 2.069 ; our ($VERSION); -$VERSION = '2.068'; +$VERSION = '2.069'; sub mkCompObject { diff --git a/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm b/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm index a52b623..7c616bf 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm @@ -4,13 +4,13 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.068 qw(:Status); -use Compress::Raw::Zlib 2.068 qw( !crc32 !adler32 ) ; +use IO::Compress::Base::Common 2.069 qw(:Status); +use Compress::Raw::Zlib 2.069 qw( !crc32 !adler32 ) ; require Exporter; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, @EXPORT, %DEFLATE_CONSTANTS); -$VERSION = '2.068'; +$VERSION = '2.069'; @ISA = qw(Exporter); @EXPORT_OK = @Compress::Raw::Zlib::DEFLATE_CONSTANTS; %EXPORT_TAGS = %Compress::Raw::Zlib::DEFLATE_CONSTANTS; diff --git a/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm b/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm index b001abe..b09897a 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm @@ -4,10 +4,10 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.068 qw(:Status); +use IO::Compress::Base::Common 2.069 qw(:Status); our ($VERSION); -$VERSION = '2.068'; +$VERSION = '2.069'; sub mkCompObject { diff --git a/cpan/IO-Compress/lib/IO/Compress/Base.pm b/cpan/IO-Compress/lib/IO/Compress/Base.pm index 20adb0e..2a0dd79 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Base.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Base.pm @@ -6,7 +6,7 @@ require 5.006 ; use strict ; use warnings; -use IO::Compress::Base::Common 2.068 ; +use IO::Compress::Base::Common 2.069 ; use IO::File (); ; use Scalar::Util (); @@ -20,7 +20,7 @@ use Symbol(); our (@ISA, $VERSION); @ISA = qw(Exporter IO::File); -$VERSION = '2.068'; +$VERSION = '2.069'; #Can't locate object method "SWASHNEW" via package "utf8" (perhaps you forgot to load "utf8"?) at .../ext/Compress-Zlib/Gzip/blib/lib/Compress/Zlib/Common.pm line 16. @@ -1041,7 +1041,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm b/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm index 86bcaa6..fc983db 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm @@ -11,7 +11,7 @@ use File::GlobMapper; require Exporter; our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE); @ISA = qw(Exporter); -$VERSION = '2.068'; +$VERSION = '2.069'; @EXPORT = qw( isaFilehandle isaFilename isaScalar whatIsInput whatIsOutput diff --git a/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm b/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm index d6c2d66..fbb9aed 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm @@ -5,16 +5,16 @@ use warnings; use bytes; require Exporter ; -use IO::Compress::Base 2.068 ; +use IO::Compress::Base 2.069 ; -use IO::Compress::Base::Common 2.068 qw(); -use IO::Compress::Adapter::Bzip2 2.068 ; +use IO::Compress::Base::Common 2.069 qw(); +use IO::Compress::Adapter::Bzip2 2.069 ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bzip2Error); -$VERSION = '2.068'; +$VERSION = '2.069'; $Bzip2Error = ''; @ISA = qw(Exporter IO::Compress::Base); @@ -51,7 +51,7 @@ sub getExtraParams { my $self = shift ; - use IO::Compress::Base::Common 2.068 qw(:Parse); + use IO::Compress::Base::Common 2.069 qw(:Parse); return ( 'blocksize100k' => [IO::Compress::Base::Common::Parse_unsigned, 1], @@ -798,7 +798,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Compress/Deflate.pm b/cpan/IO-Compress/lib/IO/Compress/Deflate.pm index 4b80953..c79b336 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Deflate.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Deflate.pm @@ -8,16 +8,16 @@ use bytes; require Exporter ; -use IO::Compress::RawDeflate 2.068 (); -use IO::Compress::Adapter::Deflate 2.068 ; +use IO::Compress::RawDeflate 2.069 (); +use IO::Compress::Adapter::Deflate 2.069 ; -use IO::Compress::Zlib::Constants 2.068 ; -use IO::Compress::Base::Common 2.068 qw(); +use IO::Compress::Zlib::Constants 2.069 ; +use IO::Compress::Base::Common 2.069 qw(); our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $DeflateError); -$VERSION = '2.068'; +$VERSION = '2.069'; $DeflateError = ''; @ISA = qw(Exporter IO::Compress::RawDeflate); @@ -932,7 +932,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Compress/FAQ.pod b/cpan/IO-Compress/lib/IO/Compress/FAQ.pod index 671824d..7f51b6c 100644 --- a/cpan/IO-Compress/lib/IO/Compress/FAQ.pod +++ b/cpan/IO-Compress/lib/IO/Compress/FAQ.pod @@ -201,7 +201,7 @@ L The primary site for gzip is F. -=head2 Dealing with Concatenated gzip files +=head2 Dealing with concatenated gzip files If the gunzip program encounters a file containing multiple gzip files concatenated together it will automatically uncompress them all. @@ -227,6 +227,17 @@ include the C option, as shown below abc def +=head2 Reading bgzip files with IO::Uncompress::Gunzip + +A C file consists of a series of valid gzip-compliant data streams +concatenated together. To read a file created by C with +C use the C option as shown in the +previous section. + +See the section titled "The BGZF compression format" in +F for a definition of +C. + =head1 ZLIB =head2 Zlib Resources @@ -665,7 +676,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Compress/Gzip.pm b/cpan/IO-Compress/lib/IO/Compress/Gzip.pm index 01ee34e..1aa5447 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Gzip.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Gzip.pm @@ -8,12 +8,12 @@ use bytes; require Exporter ; -use IO::Compress::RawDeflate 2.068 () ; -use IO::Compress::Adapter::Deflate 2.068 ; +use IO::Compress::RawDeflate 2.069 () ; +use IO::Compress::Adapter::Deflate 2.069 ; -use IO::Compress::Base::Common 2.068 qw(:Status ); -use IO::Compress::Gzip::Constants 2.068 ; -use IO::Compress::Zlib::Extra 2.068 ; +use IO::Compress::Base::Common 2.069 qw(:Status ); +use IO::Compress::Gzip::Constants 2.069 ; +use IO::Compress::Zlib::Extra 2.069 ; BEGIN { @@ -25,7 +25,7 @@ BEGIN our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $GzipError); -$VERSION = '2.068'; +$VERSION = '2.069'; $GzipError = '' ; @ISA = qw(Exporter IO::Compress::RawDeflate); @@ -1244,7 +1244,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm b/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm index 2b73a3c..293905c 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm @@ -9,7 +9,7 @@ require Exporter; our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names); our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE); -$VERSION = '2.068'; +$VERSION = '2.069'; @ISA = qw(Exporter); diff --git a/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm b/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm index 2209952..7eabff9 100644 --- a/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm +++ b/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm @@ -6,15 +6,15 @@ use strict ; use warnings; use bytes; -use IO::Compress::Base 2.068 ; -use IO::Compress::Base::Common 2.068 qw(:Status ); -use IO::Compress::Adapter::Deflate 2.068 ; +use IO::Compress::Base 2.069 ; +use IO::Compress::Base::Common 2.069 qw(:Status ); +use IO::Compress::Adapter::Deflate 2.069 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %DEFLATE_CONSTANTS, %EXPORT_TAGS, $RawDeflateError); -$VERSION = '2.068'; +$VERSION = '2.069'; $RawDeflateError = ''; @ISA = qw(Exporter IO::Compress::Base); @@ -116,8 +116,8 @@ sub getExtraParams return getZlibParams(); } -use IO::Compress::Base::Common 2.068 qw(:Parse); -use Compress::Raw::Zlib 2.068 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY); +use IO::Compress::Base::Common 2.069 qw(:Parse); +use Compress::Raw::Zlib 2.069 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY); our %PARAMS = ( #'method' => [IO::Compress::Base::Common::Parse_unsigned, Z_DEFLATED], 'level' => [IO::Compress::Base::Common::Parse_signed, Z_DEFAULT_COMPRESSION], @@ -988,7 +988,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Compress/Zip.pm b/cpan/IO-Compress/lib/IO/Compress/Zip.pm index f8ec20c..9e0d1c9 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Zip.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Zip.pm @@ -4,30 +4,30 @@ use strict ; use warnings; use bytes; -use IO::Compress::Base::Common 2.068 qw(:Status ); -use IO::Compress::RawDeflate 2.068 (); -use IO::Compress::Adapter::Deflate 2.068 ; -use IO::Compress::Adapter::Identity 2.068 ; -use IO::Compress::Zlib::Extra 2.068 ; -use IO::Compress::Zip::Constants 2.068 ; +use IO::Compress::Base::Common 2.069 qw(:Status ); +use IO::Compress::RawDeflate 2.069 (); +use IO::Compress::Adapter::Deflate 2.069 ; +use IO::Compress::Adapter::Identity 2.069 ; +use IO::Compress::Zlib::Extra 2.069 ; +use IO::Compress::Zip::Constants 2.069 ; use File::Spec(); use Config; -use Compress::Raw::Zlib 2.068 (); +use Compress::Raw::Zlib 2.069 (); BEGIN { eval { require IO::Compress::Adapter::Bzip2 ; - import IO::Compress::Adapter::Bzip2 2.068 ; + import IO::Compress::Adapter::Bzip2 2.069 ; require IO::Compress::Bzip2 ; - import IO::Compress::Bzip2 2.068 ; + import IO::Compress::Bzip2 2.069 ; } ; eval { require IO::Compress::Adapter::Lzma ; - import IO::Compress::Adapter::Lzma 2.068 ; + import IO::Compress::Adapter::Lzma 2.069 ; require IO::Compress::Lzma ; - import IO::Compress::Lzma 2.068 ; + import IO::Compress::Lzma 2.069 ; } ; } @@ -36,7 +36,7 @@ require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $ZipError); -$VERSION = '2.068'; +$VERSION = '2.069'; $ZipError = ''; @ISA = qw(Exporter IO::Compress::RawDeflate); @@ -275,6 +275,9 @@ sub mkHeader my $x = ''; $x .= pack "V V", 0, 0 ; # uncompressedLength $x .= pack "V V", 0, 0 ; # compressedLength + + # Zip64 needs to be first in extra field to workaround a Windows Explorer Bug + # See http://www.info-zip.org/phpBB3/viewtopic.php?f=3&t=440 for details $extra .= IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_ZIP64, $x); } @@ -397,13 +400,10 @@ sub mkHeader } $ctl .= $filename ; - $ctl .= $ctlExtra ; - $ctl .= $comment ; *$self->{ZipData}{Offset}->add32(length $hdr) ; - *$self->{ZipData}{CentralHeader} = $ctl; - + *$self->{ZipData}{CentralHeader} = [ $ctl, $ctlExtra, $comment]; return $hdr; } @@ -420,7 +420,7 @@ sub mkTrailer $crc32 = pack "V", *$self->{ZipData}{CRC32}; } - my $ctl = *$self->{ZipData}{CentralHeader} ; + my ($ctl, $ctlExtra, $comment) = @{ *$self->{ZipData}{CentralHeader} }; my $sizes ; if (! *$self->{ZipData}{Zip64}) { @@ -434,7 +434,6 @@ sub mkTrailer my $data = $crc32 . $sizes ; - my $xtrasize = *$self->{UnCompSize}->getPacked_V64() ; # Uncompressed size $xtrasize .= *$self->{CompSize}->getPacked_V64() ; # Compressed size @@ -456,38 +455,44 @@ sub mkTrailer substr($ctl, 16, length $crc32) = $crc32 ; - my $x = ''; + my $zip64Payload = ''; - # uncompressed length - if (*$self->{UnCompSize}->isAlmost64bit() || *$self->{ZipData}{Zip64} > 1) { - $x .= *$self->{UnCompSize}->getPacked_V64() ; + # uncompressed length - only set zip64 if needed + if (*$self->{UnCompSize}->isAlmost64bit()) { # || *$self->{ZipData}{Zip64}) { + $zip64Payload .= *$self->{UnCompSize}->getPacked_V64() ; } else { substr($ctl, 24, 4) = *$self->{UnCompSize}->getPacked_V32() ; } - # compressed length - if (*$self->{CompSize}->isAlmost64bit() || *$self->{ZipData}{Zip64} > 1) { - $x .= *$self->{CompSize}->getPacked_V64() ; + # compressed length - only set zip64 if needed + if (*$self->{CompSize}->isAlmost64bit()) { # || *$self->{ZipData}{Zip64}) { + $zip64Payload .= *$self->{CompSize}->getPacked_V64() ; } else { substr($ctl, 20, 4) = *$self->{CompSize}->getPacked_V32() ; } # Local Header offset - $x .= *$self->{ZipData}{LocalHdrOffset}->getPacked_V64() + $zip64Payload .= *$self->{ZipData}{LocalHdrOffset}->getPacked_V64() if *$self->{ZipData}{LocalHdrOffset}->is64bit() ; - # disk no - always zero, so don't need it - #$x .= pack "V", 0 ; + # disk no - always zero, so don't need to include it. + #$zip64Payload .= pack "V", 0 ; - if (length $x) { - my $xtra = IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_ZIP64, $x); - $ctl .= $xtra ; + my $zip64Xtra = ''; + + if (length $zip64Payload) { + $zip64Xtra = IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_ZIP64, $zip64Payload); + substr($ctl, *$self->{ZipData}{ExtraOffset}, 2) = - pack 'v', *$self->{ZipData}{ExtraSize} + length $xtra; + pack 'v', *$self->{ZipData}{ExtraSize} + length $zip64Xtra; *$self->{ZipData}{AnyZip64} = 1; } + # Zip64 needs to be first in extra field to workaround a Windows Explorer Bug + # See http://www.info-zip.org/phpBB3/viewtopic.php?f=3&t=440 for details + $ctl .= $zip64Xtra . $ctlExtra . $comment; + *$self->{ZipData}{Offset}->add32(length($hdr)); *$self->{ZipData}{Offset}->add( *$self->{CompSize} ); push @{ *$self->{ZipData}{CentralDir} }, $ctl ; @@ -1953,7 +1958,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm b/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm index bc56966..40ad060 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm @@ -7,7 +7,7 @@ require Exporter; our ($VERSION, @ISA, @EXPORT, %ZIP_CM_MIN_VERSIONS); -$VERSION = '2.068'; +$VERSION = '2.069'; @ISA = qw(Exporter); diff --git a/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm b/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm index f85364d..13fd7d2 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm @@ -9,7 +9,7 @@ require Exporter; our ($VERSION, @ISA, @EXPORT); -$VERSION = '2.068'; +$VERSION = '2.069'; @ISA = qw(Exporter); diff --git a/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm b/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm index f99b9ed..ecec7a9 100644 --- a/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm +++ b/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm @@ -8,9 +8,9 @@ use bytes; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS); -$VERSION = '2.068'; +$VERSION = '2.069'; -use IO::Compress::Gzip::Constants 2.068 ; +use IO::Compress::Gzip::Constants 2.069 ; sub ExtraFieldError { diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm index 0161b8f..6086cd8 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm @@ -4,12 +4,12 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.068 qw(:Status); +use IO::Compress::Base::Common 2.069 qw(:Status); -use Compress::Raw::Bzip2 2.068 ; +use Compress::Raw::Bzip2 2.069 ; our ($VERSION, @ISA); -$VERSION = '2.068'; +$VERSION = '2.069'; sub mkUncompObject { diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm index ecc66b9..5ce6714 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm @@ -4,14 +4,14 @@ use warnings; use strict; use bytes; -use IO::Compress::Base::Common 2.068 qw(:Status); +use IO::Compress::Base::Common 2.069 qw(:Status); use IO::Compress::Zip::Constants ; our ($VERSION); -$VERSION = '2.068'; +$VERSION = '2.069'; -use Compress::Raw::Zlib 2.068 (); +use Compress::Raw::Zlib 2.069 (); sub mkUncompObject { diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm index 2cfe61e..fafa385 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm @@ -4,11 +4,11 @@ use strict; use warnings; #use bytes; -use IO::Compress::Base::Common 2.068 qw(:Status); -use Compress::Raw::Zlib 2.068 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS); +use IO::Compress::Base::Common 2.069 qw(:Status); +use Compress::Raw::Zlib 2.069 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS); our ($VERSION); -$VERSION = '2.068'; +$VERSION = '2.069'; diff --git a/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm index fd0bd69..50e586e 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm @@ -6,22 +6,22 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.068 (); +use IO::Compress::Base::Common 2.069 (); -use IO::Uncompress::Adapter::Inflate 2.068 (); +use IO::Uncompress::Adapter::Inflate 2.069 (); -use IO::Uncompress::Base 2.068 ; -use IO::Uncompress::Gunzip 2.068 ; -use IO::Uncompress::Inflate 2.068 ; -use IO::Uncompress::RawInflate 2.068 ; -use IO::Uncompress::Unzip 2.068 ; +use IO::Uncompress::Base 2.069 ; +use IO::Uncompress::Gunzip 2.069 ; +use IO::Uncompress::Inflate 2.069 ; +use IO::Uncompress::RawInflate 2.069 ; +use IO::Uncompress::Unzip 2.069 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyInflateError); -$VERSION = '2.068'; +$VERSION = '2.069'; $AnyInflateError = ''; @ISA = qw( Exporter IO::Uncompress::Base ); @@ -48,7 +48,7 @@ sub anyinflate sub getExtraParams { - use IO::Compress::Base::Common 2.068 qw(:Parse); + use IO::Compress::Base::Common 2.069 qw(:Parse); return ( 'rawinflate' => [Parse_boolean, 0] ) ; } @@ -995,7 +995,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm b/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm index 0d2568e..d44b225 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm @@ -4,16 +4,16 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.068 (); +use IO::Compress::Base::Common 2.069 (); -use IO::Uncompress::Base 2.068 ; +use IO::Uncompress::Base 2.069 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyUncompressError); -$VERSION = '2.068'; +$VERSION = '2.069'; $AnyUncompressError = ''; @ISA = qw( Exporter IO::Uncompress::Base ); @@ -27,22 +27,22 @@ Exporter::export_ok_tags('all'); BEGIN { - eval ' use IO::Uncompress::Adapter::Inflate 2.068 ;'; - eval ' use IO::Uncompress::Adapter::Bunzip2 2.068 ;'; - eval ' use IO::Uncompress::Adapter::LZO 2.068 ;'; - eval ' use IO::Uncompress::Adapter::Lzf 2.068 ;'; - eval ' use IO::Uncompress::Adapter::UnLzma 2.068 ;'; - eval ' use IO::Uncompress::Adapter::UnXz 2.068 ;'; - - eval ' use IO::Uncompress::Bunzip2 2.068 ;'; - eval ' use IO::Uncompress::UnLzop 2.068 ;'; - eval ' use IO::Uncompress::Gunzip 2.068 ;'; - eval ' use IO::Uncompress::Inflate 2.068 ;'; - eval ' use IO::Uncompress::RawInflate 2.068 ;'; - eval ' use IO::Uncompress::Unzip 2.068 ;'; - eval ' use IO::Uncompress::UnLzf 2.068 ;'; - eval ' use IO::Uncompress::UnLzma 2.068 ;'; - eval ' use IO::Uncompress::UnXz 2.068 ;'; + eval ' use IO::Uncompress::Adapter::Inflate 2.069 ;'; + eval ' use IO::Uncompress::Adapter::Bunzip2 2.069 ;'; + eval ' use IO::Uncompress::Adapter::LZO 2.069 ;'; + eval ' use IO::Uncompress::Adapter::Lzf 2.069 ;'; + eval ' use IO::Uncompress::Adapter::UnLzma 2.069 ;'; + eval ' use IO::Uncompress::Adapter::UnXz 2.069 ;'; + + eval ' use IO::Uncompress::Bunzip2 2.069 ;'; + eval ' use IO::Uncompress::UnLzop 2.069 ;'; + eval ' use IO::Uncompress::Gunzip 2.069 ;'; + eval ' use IO::Uncompress::Inflate 2.069 ;'; + eval ' use IO::Uncompress::RawInflate 2.069 ;'; + eval ' use IO::Uncompress::Unzip 2.069 ;'; + eval ' use IO::Uncompress::UnLzf 2.069 ;'; + eval ' use IO::Uncompress::UnLzma 2.069 ;'; + eval ' use IO::Uncompress::UnXz 2.069 ;'; } sub new @@ -1025,7 +1025,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Base.pm b/cpan/IO-Compress/lib/IO/Uncompress/Base.pm index 04348a2..93c05de 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Base.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Base.pm @@ -9,12 +9,12 @@ our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS); @ISA = qw(Exporter IO::File); -$VERSION = '2.068'; +$VERSION = '2.069'; use constant G_EOF => 0 ; use constant G_ERR => -1 ; -use IO::Compress::Base::Common 2.068 ; +use IO::Compress::Base::Common 2.069 ; use IO::File ; use Symbol; @@ -1549,7 +1549,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm b/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm index c6e7f46..46b5ea1 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm @@ -4,15 +4,15 @@ use strict ; use warnings; use bytes; -use IO::Compress::Base::Common 2.068 qw(:Status ); +use IO::Compress::Base::Common 2.069 qw(:Status ); -use IO::Uncompress::Base 2.068 ; -use IO::Uncompress::Adapter::Bunzip2 2.068 ; +use IO::Uncompress::Base 2.069 ; +use IO::Uncompress::Adapter::Bunzip2 2.069 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bunzip2Error); -$VERSION = '2.068'; +$VERSION = '2.069'; $Bunzip2Error = ''; @ISA = qw( Exporter IO::Uncompress::Base ); @@ -903,7 +903,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm b/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm index 1f33f0b..bd698f4 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm @@ -9,12 +9,12 @@ use strict ; use warnings; use bytes; -use IO::Uncompress::RawInflate 2.068 ; +use IO::Uncompress::RawInflate 2.069 ; -use Compress::Raw::Zlib 2.068 () ; -use IO::Compress::Base::Common 2.068 qw(:Status ); -use IO::Compress::Gzip::Constants 2.068 ; -use IO::Compress::Zlib::Extra 2.068 ; +use Compress::Raw::Zlib 2.069 () ; +use IO::Compress::Base::Common 2.069 qw(:Status ); +use IO::Compress::Gzip::Constants 2.069 ; +use IO::Compress::Zlib::Extra 2.069 ; require Exporter ; @@ -28,7 +28,7 @@ Exporter::export_ok_tags('all'); $GunzipError = ''; -$VERSION = '2.068'; +$VERSION = '2.069'; sub new { @@ -1118,7 +1118,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm index 1330731..f62cfac 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm @@ -5,15 +5,15 @@ use strict ; use warnings; use bytes; -use IO::Compress::Base::Common 2.068 qw(:Status ); -use IO::Compress::Zlib::Constants 2.068 ; +use IO::Compress::Base::Common 2.069 qw(:Status ); +use IO::Compress::Zlib::Constants 2.069 ; -use IO::Uncompress::RawInflate 2.068 ; +use IO::Uncompress::RawInflate 2.069 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $InflateError); -$VERSION = '2.068'; +$VERSION = '2.069'; $InflateError = ''; @ISA = qw( Exporter IO::Uncompress::RawInflate ); @@ -990,7 +990,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm b/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm index 3a375a7..c052971 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm @@ -5,16 +5,16 @@ use strict ; use warnings; #use bytes; -use Compress::Raw::Zlib 2.068 ; -use IO::Compress::Base::Common 2.068 qw(:Status ); +use Compress::Raw::Zlib 2.069 ; +use IO::Compress::Base::Common 2.069 qw(:Status ); -use IO::Uncompress::Base 2.068 ; -use IO::Uncompress::Adapter::Inflate 2.068 ; +use IO::Uncompress::Base 2.069 ; +use IO::Uncompress::Adapter::Inflate 2.069 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $RawInflateError); -$VERSION = '2.068'; +$VERSION = '2.069'; $RawInflateError = ''; @ISA = qw( Exporter IO::Uncompress::Base ); @@ -1118,7 +1118,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm b/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm index f73313f..0ee6df4 100644 --- a/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm +++ b/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm @@ -9,14 +9,14 @@ use warnings; #use bytes; use IO::File; -use IO::Uncompress::RawInflate 2.068 ; -use IO::Compress::Base::Common 2.068 qw(:Status ); -use IO::Uncompress::Adapter::Inflate 2.068 ; -use IO::Uncompress::Adapter::Identity 2.068 ; -use IO::Compress::Zlib::Extra 2.068 ; -use IO::Compress::Zip::Constants 2.068 ; +use IO::Uncompress::RawInflate 2.069 ; +use IO::Compress::Base::Common 2.069 qw(:Status ); +use IO::Uncompress::Adapter::Inflate 2.069 ; +use IO::Uncompress::Adapter::Identity 2.069 ; +use IO::Compress::Zlib::Extra 2.069 ; +use IO::Compress::Zip::Constants 2.069 ; -use Compress::Raw::Zlib 2.068 () ; +use Compress::Raw::Zlib 2.069 () ; BEGIN { @@ -31,7 +31,7 @@ require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $UnzipError, %headerLookup); -$VERSION = '2.068'; +$VERSION = '2.069'; $UnzipError = ''; @ISA = qw(Exporter IO::Uncompress::RawInflate); @@ -1861,7 +1861,7 @@ See the Changes file. =head1 COPYRIGHT AND LICENSE -Copyright (c) 2005-2014 Paul Marquess. All rights reserved. +Copyright (c) 2005-2015 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/IO-Compress/t/000prereq.t b/cpan/IO-Compress/t/000prereq.t index 997c70e..3ccc7f0 100644 --- a/cpan/IO-Compress/t/000prereq.t +++ b/cpan/IO-Compress/t/000prereq.t @@ -25,7 +25,7 @@ BEGIN if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - my $VERSION = '2.068'; + my $VERSION = '2.069'; my @NAMES = qw( Compress::Raw::Bzip2 Compress::Raw::Zlib diff --git a/cpan/Math-BigInt-FastCalc/lib/Math/BigInt/FastCalc.pm b/cpan/Math-BigInt-FastCalc/lib/Math/BigInt/FastCalc.pm index 9bf5a60..71a7b68 100644 --- a/cpan/Math-BigInt-FastCalc/lib/Math/BigInt/FastCalc.pm +++ b/cpan/Math-BigInt-FastCalc/lib/Math/BigInt/FastCalc.pm @@ -8,7 +8,7 @@ use Math::BigInt::Calc 1.997; use vars '$VERSION'; -$VERSION = '0.31'; +$VERSION = '0.34'; ############################################################################## # global constants, flags and accessory @@ -43,7 +43,9 @@ XSLoader::load(__PACKAGE__, $VERSION, Math::BigInt::Calc::_base_len()); ############################################################################## 1; + __END__ + =pod =head1 NAME @@ -88,6 +90,65 @@ The following functions are now implemented in FastCalc.xs: _inc _dec __strip_zeros _copy +=head1 BUGS + +Please report any bugs or feature requests to +C, or through the web interface at +L +(requires login). +We will be notified, and then you'll automatically be notified of progress on +your bug as I make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Math::BigInt::FastCalc + +You can also look for information at: + +=over 4 + +=item * RT: CPAN's request tracker + +L + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * Search CPAN + +L + +=item * CPAN Testers Matrix + +L + +=item * The Bignum mailing list + +=over 4 + +=item * Post to mailing list + +C + +=item * View mailing list + +L + +=item * Subscribe/Unsubscribe + +L + +=back + +=back + =head1 LICENSE This program is free software; you may redistribute it and/or modify it under @@ -102,11 +163,11 @@ Separated from BigInt and shaped API with the help of John Peacock. Fixed, sped-up and enhanced by Tels http://bloodgate.com 2001-2003. Further streamlining (api_version 1 etc.) by Tels 2004-2007. -Bug-fixing by Peter John Acklam Epjacklam@online.noE 2010-2011. +Bug-fixing by Peter John Acklam Epjacklam@online.noE 2010-2015. =head1 SEE ALSO -L, L, -L, L and L. +L, L, and the other backends +L, L, and L. =cut diff --git a/cpan/Math-BigInt/lib/Math/BigFloat.pm b/cpan/Math-BigInt/lib/Math/BigFloat.pm index a423b35..97e8340 100644 --- a/cpan/Math-BigInt/lib/Math/BigFloat.pm +++ b/cpan/Math-BigInt/lib/Math/BigFloat.pm @@ -12,7 +12,7 @@ package Math::BigFloat; # _a : accuracy # _p : precision -$VERSION = '1.999701'; +$VERSION = '1.999704'; require 5.006002; require Exporter; @@ -860,19 +860,24 @@ sub blog { my ($self,$x,$base,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_); + # If called as $x -> blog() or $x -> blog(undef), don't objectify the + # undefined base, since undef signals that the base is Euler's number. + #unless (ref($x) && !defined($base)) { + # # objectify is costly, so avoid it + # if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { + # ($self,$x,$base,$a,$p,$r) = objectify(2,@_); + # } + #} + return $x if $x->modify('blog'); - # $base > 0, $base != 1; if $base == undef default to $base == e - # $x >= 0 + return $x -> bnan() if $x -> is_nan(); # we need to limit the accuracy to protect against overflow my $fallback = 0; my ($scale,@params); ($x,@params) = $x->_find_round_parameters($a,$p,$r); - # also takes care of the "error in _find_round_parameters?" case - return $x->bnan() if $x->{sign} ne '+' || $x->is_zero(); - # no rounding at all, so must use fallback if (scalar @params == 0) { @@ -890,28 +895,62 @@ sub blog $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined } - return $x->bzero(@params) if $x->is_one(); - # base not defined => base == Euler's number e - if (defined $base) - { - # make object, since we don't feed it through objectify() to still get the - # case of $base == undef - $base = $self->new($base) unless ref($base); - # $base > 0; $base != 1 - return $x->bnan() if $base->is_zero() || $base->is_one() || - $base->{sign} ne '+'; - # if $x == $base, we know the result must be 1.0 - if ($x->bcmp($base) == 0) - { - $x->bone('+',@params); - if ($fallback) - { + my $done = 0; + if (defined $base) { + $base = $self -> new($base) unless ref $base; + if ($base -> is_nan() || $base -> is_one()) { + $x -> bnan(); + $done = 1; + } elsif ($base -> is_inf() || $base -> is_zero()) { + if ($x -> is_inf() || $x -> is_zero()) { + $x -> bnan(); + } else { + $x -> bzero(@params); + } + $done = 1; + } elsif ($base -> is_negative()) { # -inf < base < 0 + if ($x -> is_one()) { # x = 1 + $x -> bzero(@params); + } elsif ($x == $base) { + $x -> bone('+', @params); # x = base + } else { + $x -> bnan(); # otherwise + } + $done = 1; + } elsif ($x == $base) { + $x -> bone('+', @params); # 0 < base && 0 < x < inf + $done = 1; + } + } + + # We now know that the base is either undefined or positive and finite. + + unless ($done) { + if ($x -> is_inf()) { # x = +/-inf + my $sign = defined $base && $base < 1 ? '-' : '+'; + $x -> binf($sign); + $done = 1; + } elsif ($x -> is_neg()) { # -inf < x < 0 + $x -> bnan(); + $done = 1; + } elsif ($x -> is_one()) { # x = 1 + $x -> bzero(@params); + $done = 1; + } elsif ($x -> is_zero()) { # x = 0 + my $sign = defined $base && $base < 1 ? '+' : '-'; + $x -> binf($sign); + $done = 1; + } + } + + if ($done) { + if ($fallback) { # clear a/p after round, since user did not request it - delete $x->{_a}; delete $x->{_p}; + delete $x->{_a}; + delete $x->{_p}; } return $x; } - } # when user set globals, they would interfere with our calculation, so # disable them and later re-enable them @@ -933,7 +972,7 @@ sub blog $self = ref($x); } - my $done = 0; + $done = 0; # If the base is defined and an integer, try to calculate integer result # first. This is very fast, and in case the real result was found, we can @@ -4396,6 +4435,24 @@ Multiply $x by $y, and then add $z to the result. This method was added in v1.87 of Math::BigInt (June 2007). +=item as_float() + +This method is called when Math::BigFloat encounters an object it doesn't know +how to handle. For instance, assume $x is a Math::BigFloat, or subclass +thereof, and $y is defined, but not a Math::BigFloat, or subclass thereof. If +you do + + $x -> badd($y); + +$y needs to be converted into an object that $x can deal with. This is done by +first checking if $y is something that $x might be upgraded to. If that is the +case, no further attempts are made. The next is to see if $y supports the +method C. The method C is expected to return either an +object that has the same class as $x, a subclass thereof, or a string that +Cnew()> can parse to create an object. + +In Math::BigFloat, C has the same effect as C. + =back =head1 Autocreating constants diff --git a/cpan/Math-BigInt/lib/Math/BigInt.pm b/cpan/Math-BigInt/lib/Math/BigInt.pm index d990272..e902655 100644 --- a/cpan/Math-BigInt/lib/Math/BigInt.pm +++ b/cpan/Math-BigInt/lib/Math/BigInt.pm @@ -18,7 +18,7 @@ package Math::BigInt; my $class = "Math::BigInt"; use 5.006002; -$VERSION = '1.999701'; +$VERSION = '1.999704'; @ISA = qw(Exporter); @EXPORT_OK = qw(objectify bgcd blcm); @@ -94,7 +94,7 @@ use overload #'oct' => sub { print "oct"; $_[0]; }, # log(N) is log(N, e), where e is Euler's number -'log' => sub { $_[0]->copy()->blog($_[1], undef); }, +'log' => sub { $_[0]->copy()->blog(); }, 'exp' => sub { $_[0]->copy()->bexp($_[1]); }, 'int' => sub { $_[0]->copy(); }, 'neg' => sub { $_[0]->copy()->bneg(); }, @@ -1277,27 +1277,52 @@ sub bdec sub blog { - # calculate $x = $a ** $base + $b and return $a (e.g. the log() to base - # $base of $x) + # Return the logarithm of the operand. If a second operand is defined, that + # value is used as the base, otherwise the base is assumed to be Euler's + # constant. + + # Don't objectify the base, since an undefined base, as in $x->blog() or + # $x->blog(undef) signals that the base is Euler's number. # set up parameters my ($self,$x,$base,@r) = (undef,@_); # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) - { - ($self,$x,$base,@r) = objectify(2,@_); - } + if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { + ($self,$x,$base,@r) = objectify(1,@_); + } return $x if $x->modify('blog'); - $base = $self->new($base) if defined $base && !ref $base; + # Handle all exception cases and all trivial cases. I have used Wolfram Alpha + # (http://www.wolframalpha.com) as the reference for these cases. + + return $x -> bnan() if $x -> is_nan(); + + if (defined $base) { + $base = $self -> new($base) unless ref $base; + if ($base -> is_nan() || $base -> is_one()) { + return $x -> bnan(); + } elsif ($base -> is_inf() || $base -> is_zero()) { + return $x -> bnan() if $x -> is_inf() || $x -> is_zero(); + return $x -> bzero(); + } elsif ($base -> is_negative()) { # -inf < base < 0 + return $x -> bzero() if $x -> is_one(); # x = 1 + return $x -> bone() if $x == $base; # x = base + return $x -> bnan(); # otherwise + } + return $x -> bone() if $x == $base; # 0 < base && 0 < x < inf + } - # inf, -inf, NaN, <0 => NaN - return $x->bnan() - if $x->{sign} ne '+' || (defined $base && $base->{sign} ne '+'); + # We now know that the base is either undefined or >= 2 and finite. - return $upgrade->blog($upgrade->new($x),$base,@r) if - defined $upgrade; + return $x -> binf('+') if $x -> is_inf(); # x = +/-inf + return $x -> bnan() if $x -> is_neg(); # -inf < x < 0 + return $x -> bzero() if $x -> is_one(); # x = 1 + return $x -> binf('-') if $x -> is_zero(); # x = 0 + + # At this point we are done handling all exception cases and trivial cases. + + return $upgrade -> blog($upgrade -> new($x), $base, @r) if defined $upgrade; # fix for bug #24969: # the default base is e (Euler's number) which is not an integer @@ -1312,7 +1337,7 @@ sub blog } my ($rc,$exact) = $CALC->_log_int($x->{value},$base->{value}); - return $x->bnan() unless defined $rc; # not possible to take log? + return $x->bnan() unless defined $rc; # not possible to take log? $x->{value} = $rc; $x->round(@r); } @@ -2801,9 +2826,7 @@ sub objectify { # If it is an object of the right class, all is fine. - if ($ref -> isa($a[0])) { - next; - } + next if $ref -> isa($a[0]); # Upgrading is OK, so skip further tests if the argument is upgraded. @@ -2811,27 +2834,44 @@ sub objectify { next; } - # If we want a Math::BigInt, see if the object can become one. - # Support the old misnomer as_number(). + # See if we can call one of the as_xxx() methods. We don't know whether + # the as_xxx() method returns an object or a scalar, so re-check + # afterwards. - if ($a[0] eq 'Math::BigInt') { + my $recheck = 0; + + if ($a[0] -> isa('Math::BigInt')) { if ($a[$i] -> can('as_int')) { $a[$i] = $a[$i] -> as_int(); - next; - } - if ($a[$i] -> can('as_number')) { + $recheck = 1; + } elsif ($a[$i] -> can('as_number')) { $a[$i] = $a[$i] -> as_number(); - next; + $recheck = 1; } } - # If we want a Math::BigFloat, see if the object can become one. - - if ($a[0] eq 'Math::BigFloat') { + elsif ($a[0] -> isa('Math::BigFloat')) { if ($a[$i] -> can('as_float')) { $a[$i] = $a[$i] -> as_float(); + $recheck = $1; + } + } + + # If we called one of the as_xxx() methods, recheck. + + if ($recheck) { + $ref = ref($a[$i]); + + # Perl scalars are fed to the appropriate constructor. + + unless ($ref) { + $a[$i] = $a[0] -> new($a[$i]); next; } + + # If it is an object of the right class, all is fine. + + next if $ref -> isa($a[0]); } # Last resort. @@ -4326,15 +4366,29 @@ Return the signed mantissa of $x as BigInt. $x->copy(); # make a true copy of $x (unlike $y = $x;) -=item as_int()/as_number() +=item as_int() + +=item as_number() + +These methods are called when Math::BigInt encounters an object it doesn't know +how to handle. For instance, assume $x is a Math::BigInt, or subclass thereof, +and $y is defined, but not a Math::BigInt, or subclass thereof. If you do + + $x -> badd($y); - $x->as_int(); +$y needs to be converted into an object that $x can deal with. This is done by +first checking if $y is something that $x might be upgraded to. If that is the +case, no further attempts are made. The next is to see if $y supports the +method C. If it does, C is called, but if it doesn't, the +next thing is to see if $y supports the method C. If it does, +C is called. The method C (and C) is +expected to return either an object that has the same class as $x, a subclass +thereof, or a string that Cnew()> can parse to create an object. -Returns $x as a BigInt (truncated towards zero). In BigInt this is the same as -C. +C is an alias to C. C was introduced in +v1.22, while C was introduced in v1.68. -C is an alias to this method. C was introduced in -v1.22, while C was only introduced in v1.68. +In Math::BigInt, C has the same effect as C. =item bstr() @@ -4365,7 +4419,7 @@ Returns a normalized string representation of C<$x>. This returns a normal Perl scalar from $x. It is used automatically whenever a scalar is needed, for instance in array index operations. -This loses precision, to avoid this use L instead. +This loses precision, to avoid this use L instead. =item modify() @@ -5390,43 +5444,34 @@ This makes a copy of $x and takes O(N), but $x->bneg() is O(1). =item Mixing different object types -In Perl you will get a floating point value if you do one of the following: - - $float = 5.0 + 2; - $float = 2 + 5.0; - $float = 5 / 2; - -With overloaded math, only the first two variants will result in a BigFloat: +With overloaded operators, it is the first (dominating) operand that determines +which method is called. Here are some examples showing what actually gets +called in various cases. use Math::BigInt; use Math::BigFloat; - $mbf = Math::BigFloat->new(5); - $mbi2 = Math::BigInteger->new(5); - $mbi = Math::BigInteger->new(2); - + $mbf = Math::BigFloat->new(5); + $mbi2 = Math::BigInt->new(5); + $mbi = Math::BigInt->new(2); # what actually gets called: - $float = $mbf + $mbi; # $mbf->badd() - $float = $mbf / $mbi; # $mbf->bdiv() - $integer = $mbi + $mbf; # $mbi->badd() - $integer = $mbi2 / $mbi; # $mbi2->bdiv() - $integer = $mbi2 / $mbf; # $mbi2->bdiv() - -This is because math with overloaded operators follows the first (dominating) -operand, and the operation of that is called and returns thus the result. So, -Math::BigInt::bdiv() will always return a Math::BigInt, regardless whether -the result should be a Math::BigFloat or the second operant is one. + $float = $mbf + $mbi; # $mbf->badd($mbi) + $float = $mbf / $mbi; # $mbf->bdiv($mbi) + $integer = $mbi + $mbf; # $mbi->badd($mbf) + $integer = $mbi2 / $mbi; # $mbi2->bdiv($mbi) + $integer = $mbi2 / $mbf; # $mbi2->bdiv($mbf) -To get a Math::BigFloat you either need to call the operation manually, -make sure the operands are already of the proper type or casted to that type -via Math::BigFloat->new(): +For instance, Math::BigInt->bdiv() will always return a Math::BigInt, regardless of +whether the second operant is a Math::BigFloat. To get a Math::BigFloat you +either need to call the operation manually, make sure each operand already is a +Math::BigFloat, or cast to that type via Math::BigFloat->new(): $float = Math::BigFloat->new($mbi2) / $mbi; # = 2.5 -Beware of simple "casting" the entire expression, this would only convert -the already computed result: +Beware of casting the entire expression, as this would cast the +result, at which point it is too late: - $float = Math::BigFloat->new($mbi2 / $mbi); # = 2.0 thus wrong! + $float = Math::BigFloat->new($mbi2 / $mbi); # = 2 Beware also of the order of more complicated expressions like: diff --git a/cpan/Math-BigInt/lib/Math/BigInt/Calc.pm b/cpan/Math-BigInt/lib/Math/BigInt/Calc.pm index ce9bf3a..3776d00 100644 --- a/cpan/Math-BigInt/lib/Math/BigInt/Calc.pm +++ b/cpan/Math-BigInt/lib/Math/BigInt/Calc.pm @@ -4,7 +4,7 @@ use 5.006002; use strict; # use warnings; # do not use warnings for older Perls -our $VERSION = '1.999701'; +our $VERSION = '1.999704'; # Package to store unsigned big integers in decimal and do math with them diff --git a/cpan/Math-BigInt/lib/Math/BigInt/CalcEmu.pm b/cpan/Math-BigInt/lib/Math/BigInt/CalcEmu.pm index 0ff9dcc..94cccb5 100644 --- a/cpan/Math-BigInt/lib/Math/BigInt/CalcEmu.pm +++ b/cpan/Math-BigInt/lib/Math/BigInt/CalcEmu.pm @@ -5,7 +5,7 @@ use strict; # use warnings; # do not use warnings for older Perls use vars qw/$VERSION/; -$VERSION = '1.999701'; +$VERSION = '1.999704'; package Math::BigInt; diff --git a/cpan/Math-BigInt/t/bare_mbf.t b/cpan/Math-BigInt/t/bare_mbf.t index 69dcc80..6eeefa7 100644 --- a/cpan/Math-BigInt/t/bare_mbf.t +++ b/cpan/Math-BigInt/t/bare_mbf.t @@ -1,7 +1,7 @@ #!/usr/bin/perl -w use strict; -use Test::More tests => 2340; +use Test::More tests => 2360; BEGIN { unshift @INC, 't'; } diff --git a/cpan/Math-BigInt/t/bare_mbi.t b/cpan/Math-BigInt/t/bare_mbi.t index 8aedf43..bc22156 100644 --- a/cpan/Math-BigInt/t/bare_mbi.t +++ b/cpan/Math-BigInt/t/bare_mbi.t @@ -1,7 +1,7 @@ #!/usr/bin/perl -w use strict; -use Test::More tests => 3649; +use Test::More tests => 3701; BEGIN { unshift @INC, 't'; } diff --git a/cpan/Math-BigInt/t/bigfltpm.inc b/cpan/Math-BigInt/t/bigfltpm.inc index 3eb2e21..bbfca4e 100644 --- a/cpan/Math-BigInt/t/bigfltpm.inc +++ b/cpan/Math-BigInt/t/bigfltpm.inc @@ -60,6 +60,9 @@ while () # some unary ops (test the fxxx form, since that is done by AUTOLOAD) } elsif ($f =~ /^f(nan|sstr|neg|floor|ceil|int|abs)$/) { $try .= "\$x->f$1();"; + # overloaded functions + } elsif ($f =~ /^(log|exp|sin|cos|atan2|int|neg|abs|sqrt)$/) { + $try .= "\$x = $f(\$x);"; # some is_xxx test function } elsif ($f =~ /^is_(zero|one|negative|positive|odd|even|nan|int)$/) { $try .= "\$x->$f();"; @@ -499,16 +502,16 @@ NaN:1:NaN 7:0:1 2:1:2 &flog -0::NaN +0::-inf -1::NaN -2::NaN # base > 0, base != 1 2:-1:NaN -2:0:NaN +2:0:0 2:1:NaN -# log(1) is always 1, regardless of $base +# log(1) 1::0 -1:1:0 +1:1:NaN 1:2:0 2::0.6931471805599453094172321214581765680755 2.718281828::0.9999999998311266953289851340574956564911 @@ -1834,3 +1837,23 @@ NaN:NaN -51.2:-51 12.2:12 -0.4:0 +# overloaded functions +&log +-1:NaN +0:-inf +1:0 +2:0.6931471805599453094172321214581765680755 +3:1.098612288668109691395245236922525704647 +123456789:18.63140176616801803319393334796320420971 +1234567890987654321:41.657252696908474880343847955484513481 +-inf:inf +inf:inf +NaN:NaN +&exp +&sin +&cos +&atan2 +&int +&neg +&abs +&sqrt diff --git a/cpan/Math-BigInt/t/bigfltpm.t b/cpan/Math-BigInt/t/bigfltpm.t index 8653f77..53006e7 100644 --- a/cpan/Math-BigInt/t/bigfltpm.t +++ b/cpan/Math-BigInt/t/bigfltpm.t @@ -1,7 +1,7 @@ #!/usr/bin/perl -w use strict; -use Test::More tests => 2340 +use Test::More tests => 2360 + 5; # own tests @@ -24,6 +24,11 @@ $c = Math::BigFloat->new('0.008'); my $d = Math::BigFloat->new(3); my $e = $c->bdiv(Math::BigFloat->new(3),$d); is ($e,'0.00267'); # '0.008 / 3 => 0.0027'); -is (ref($e->{_e}->[0]), ''); # 'Not a BigInt'); + +SKIP: { + skip("skipping test which is not for this backend", 1) + unless $CL eq 'Math::BigInt::Calc'; + is (ref($e->{_e}->[0]), ''); # 'Not a BigInt'); +} require 't/bigfltpm.inc'; # all tests here for sharing diff --git a/cpan/Math-BigInt/t/bigintpm.inc b/cpan/Math-BigInt/t/bigintpm.inc index 08a98ac..0b8206e 100644 --- a/cpan/Math-BigInt/t/bigintpm.inc +++ b/cpan/Math-BigInt/t/bigintpm.inc @@ -75,6 +75,9 @@ while () # some unary ops } elsif ($f =~ /^b(nan|floor|ceil|int|sstr|neg|abs|sgn|inc|dec|not|sqrt|fac)$/) { $try .= "\$x->$f();"; + # overloaded functions + } elsif ($f =~ /^(log|exp|sin|cos|atan2|int|neg|abs|sqrt)$/) { + $try .= "\$x = $f(\$x);"; } elsif ($f =~ /^(numify|length|stringify|as_hex|as_bin)$/) { $try .= "\$x->$f();"; } elsif ($f eq "exponent"){ @@ -549,140 +552,144 @@ SKIP: { # the following tests only make sense with Math::BigInt::Calc or BareCalc or # FastCalc -exit if $CALC !~ /^Math::BigInt::(|Bare|Fast)Calc$/; # for Pari et al. - -############################################################################### -# check proper length of internal arrays - -my $bl = $CL->_base_len(); -my $BASE = '9' x $bl; -my $MAX = $BASE; -$BASE++; - -$x = $class->new($MAX); is_valid($x); # f.i. 9999 -$x += 1; is ($x,$BASE); is_valid($x); # 10000 -$x -= 1; is ($x,$MAX); is_valid($x); # 9999 again - -############################################################################### -# check numify - -$x = $class->new($BASE-1); is ($x->numify(),$BASE-1); -$x = $class->new(-($BASE-1)); is ($x->numify(),-($BASE-1)); - -# +0 is to protect from 1e15 vs 100000000 (stupid to_string aaaarglburblll...) -$x = $class->new($BASE); is ($x->numify()+0,$BASE+0); -$x = $class->new(-$BASE); is ($x->numify(),-$BASE); -$x = $class->new( -($BASE*$BASE*1+$BASE*1+1) ); -is ($x->numify(),-($BASE*$BASE*1+$BASE*1+1)); - -############################################################################### -# test bug in _digits with length($c[-1]) where $c[-1] was "00001" instead of 1 +SKIP: { + # skip GMP, Pari et al. + skip("skipping tests not intended for the backend $CALC", 50) + unless $CALC =~ /^Math::BigInt::(Bare|Fast)?Calc$/; -$x = $class->new($BASE-2); $x++; $x++; $x++; $x++; -if ($x > $BASE) { is (1,1) } else { is ("$x < $BASE","$x > $BASE"); } + ########################################################################### + # check proper length of internal arrays -$x = $class->new($BASE+3); $x++; -if ($x > $BASE) { is (1,1) } else { is ("$x > $BASE","$x < $BASE"); } + my $bl = $CL->_base_len(); + my $BASE = '9' x $bl; + my $MAX = $BASE; + $BASE++; -# test for +0 instead of int(): -$x = $class->new($MAX); is ($x->length(), length($MAX)); + $x = $class->new($MAX); is_valid($x); # f.i. 9999 + $x += 1; is ($x,$BASE); is_valid($x); # 10000 + $x -= 1; is ($x,$MAX); is_valid($x); # 9999 again -############################################################################### -# test bug that $class->digit($string) did not work + ########################################################################### + # check numify -is ($class->digit(123,2),1); + $x = $class->new($BASE-1); is ($x->numify(),$BASE-1); + $x = $class->new(-($BASE-1)); is ($x->numify(),-($BASE-1)); -############################################################################### -# bug in sub where number with at least 6 trailing zeros after any op failed + # +0 is to protect from 1e15 vs 100000000 (stupid to_string aaaarglburblll...) + $x = $class->new($BASE); is ($x->numify()+0,$BASE+0); + $x = $class->new(-$BASE); is ($x->numify(),-$BASE); + $x = $class->new( -($BASE*$BASE*1+$BASE*1+1) ); + is ($x->numify(),-($BASE*$BASE*1+$BASE*1+1)); -$x = $class->new(123456); $z = $class->new(10000); $z *= 10; $x -= $z; -is ($z, 100000); -is ($x, 23456); + ########################################################################### + # test bug in _digits with length($c[-1]) where $c[-1] was "00001" instead of 1 -############################################################################### -# bug in shortcut in mul() - -# construct a number with a zero-hole of BASE_LEN_SMALL -{ - my @bl = $CL->_base_len(); my $bl = $bl[5]; - - $x = '1' x $bl . '0' x $bl . '1' x $bl . '0' x $bl; - $y = '1' x (2*$bl); - $x = $class->new($x)->bmul($y); - # result is 123..$bl . $bl x (3*bl-1) . $bl...321 . '0' x $bl - $y = ''; my $d = ''; - for (my $i = 1; $i <= $bl; $i++) - { - $y .= $i; $d = $i.$d; - } - $y .= $bl x (3*$bl-1) . $d . '0' x $bl; - is ($x,$y); - - - ############################################################################# - # see if mul shortcut for small numbers works - - $x = '9' x $bl; - $x = $class->new($x); - # 999 * 999 => 998 . 001, 9999*9999 => 9998 . 0001 - is ($x*$x, '9' x ($bl-1) . '8' . '0' x ($bl-1) . '1'); -} + $x = $class->new($BASE-2); $x++; $x++; $x++; $x++; + if ($x > $BASE) { is (1,1) } else { is ("$x < $BASE","$x > $BASE"); } -############################################################################### -# bug with rest "-0" in div, causing further div()s to fail + $x = $class->new($BASE+3); $x++; + if ($x > $BASE) { is (1,1) } else { is ("$x > $BASE","$x < $BASE"); } -$x = $class->new('-322056000'); ($x,$y) = $x->bdiv('-12882240'); + # test for +0 instead of int(): + $x = $class->new($MAX); is ($x->length(), length($MAX)); -is ($y,'0'); is_valid($y); # $y not '-0' + ########################################################################### + # test bug that $class->digit($string) did not work -############################################################################### -# bug in $x->bmod($y) + is ($class->digit(123,2),1); -# if $x < 0 and $y > 0 -$x = $class->new('-629'); is ($x->bmod(5033),4404); + ########################################################################### + # bug in sub where number with at least 6 trailing zeros after any op failed -############################################################################### -# bone/binf etc as plain calls (Lite failed them) - -is ($class->bzero(),0); -is ($class->bone(),1); -is ($class->bone('+'),1); -is ($class->bone('-'),-1); -is ($class->bnan(),'NaN'); -is ($class->binf(),'inf'); -is ($class->binf('+'),'inf'); -is ($class->binf('-'),'-inf'); -is ($class->binf('-inf'),'-inf'); + $x = $class->new(123456); $z = $class->new(10000); $z *= 10; $x -= $z; + is ($z, 100000); + is ($x, 23456); -############################################################################### -# is_one('-') + ########################################################################### + # bug in shortcut in mul() -is ($class->new(1)->is_one('-'),0); -is ($class->new(-1)->is_one('-'),1); -is ($class->new(1)->is_one(),1); -is ($class->new(-1)->is_one(),0); + # construct a number with a zero-hole of BASE_LEN_SMALL + { + my @bl = $CL->_base_len(); my $bl = $bl[5]; + + $x = '1' x $bl . '0' x $bl . '1' x $bl . '0' x $bl; + $y = '1' x (2*$bl); + $x = $class->new($x)->bmul($y); + # result is 123..$bl . $bl x (3*bl-1) . $bl...321 . '0' x $bl + $y = ''; my $d = ''; + for (my $i = 1; $i <= $bl; $i++) + { + $y .= $i; $d = $i.$d; + } + $y .= $bl x (3*$bl-1) . $d . '0' x $bl; + is ($x,$y); + + + ######################################################################### + # see if mul shortcut for small numbers works + + $x = '9' x $bl; + $x = $class->new($x); + # 999 * 999 => 998 . 001, 9999*9999 => 9998 . 0001 + is ($x*$x, '9' x ($bl-1) . '8' . '0' x ($bl-1) . '1'); + } -############################################################################### -# [perl #30609] bug with $x -= $x not being 0, but 2*$x - -$x = $class->new(3); $x -= $x; is ($x, 0); -$x = $class->new(-3); $x -= $x; is ($x, 0); -$x = $class->new('NaN'); $x -= $x; is ($x->is_nan(), 1); -$x = $class->new('inf'); $x -= $x; is ($x->is_nan(), 1); -$x = $class->new('-inf'); $x -= $x; is ($x->is_nan(), 1); - -$x = $class->new('NaN'); $x += $x; is ($x->is_nan(), 1); -$x = $class->new('inf'); $x += $x; is ($x->is_inf(), 1); -$x = $class->new('-inf'); $x += $x; is ($x->is_inf('-'), 1); -$x = $class->new(3); $x += $x; is ($x, 6); -$x = $class->new(-3); $x += $x; is ($x, -6); - -$x = $class->new(3); $x *= $x; is ($x, 9); -$x = $class->new(-3); $x *= $x; is ($x, 9); -$x = $class->new(3); $x /= $x; is ($x, 1); -$x = $class->new(-3); $x /= $x; is ($x, 1); -$x = $class->new(3); $x %= $x; is ($x, 0); -$x = $class->new(-3); $x %= $x; is ($x, 0); + ########################################################################### + # bug with rest "-0" in div, causing further div()s to fail + + $x = $class->new('-322056000'); ($x,$y) = $x->bdiv('-12882240'); + + is ($y,'0'); is_valid($y); # $y not '-0' + + ########################################################################### + # bug in $x->bmod($y) + + # if $x < 0 and $y > 0 + $x = $class->new('-629'); is ($x->bmod(5033),4404); + + ########################################################################### + # bone/binf etc as plain calls (Lite failed them) + + is ($class->bzero(),0); + is ($class->bone(),1); + is ($class->bone('+'),1); + is ($class->bone('-'),-1); + is ($class->bnan(),'NaN'); + is ($class->binf(),'inf'); + is ($class->binf('+'),'inf'); + is ($class->binf('-'),'-inf'); + is ($class->binf('-inf'),'-inf'); + + ########################################################################### + # is_one('-') + + is ($class->new(1)->is_one('-'),0); + is ($class->new(-1)->is_one('-'),1); + is ($class->new(1)->is_one(),1); + is ($class->new(-1)->is_one(),0); + + ########################################################################### + # [perl #30609] bug with $x -= $x not being 0, but 2*$x + + $x = $class->new(3); $x -= $x; is ($x, 0); + $x = $class->new(-3); $x -= $x; is ($x, 0); + $x = $class->new('NaN'); $x -= $x; is ($x->is_nan(), 1); + $x = $class->new('inf'); $x -= $x; is ($x->is_nan(), 1); + $x = $class->new('-inf'); $x -= $x; is ($x->is_nan(), 1); + + $x = $class->new('NaN'); $x += $x; is ($x->is_nan(), 1); + $x = $class->new('inf'); $x += $x; is ($x->is_inf(), 1); + $x = $class->new('-inf'); $x += $x; is ($x->is_inf('-'), 1); + $x = $class->new(3); $x += $x; is ($x, 6); + $x = $class->new(-3); $x += $x; is ($x, -6); + + $x = $class->new(3); $x *= $x; is ($x, 9); + $x = $class->new(-3); $x *= $x; is ($x, 9); + $x = $class->new(3); $x /= $x; is ($x, 1); + $x = $class->new(-3); $x /= $x; is ($x, 1); + $x = $class->new(3); $x %= $x; is ($x, 0); + $x = $class->new(-3); $x %= $x; is ($x, 0); +} ############################################################################### # all tests done @@ -745,18 +752,40 @@ __DATA__ &^= 5:7:2 &blog +# NaNlog:2:NaN 122:NaNlog:NaN NaNlog1:NaNlog:NaN -122:inf:NaN -inf:122:NaN -122:-inf:NaN --inf:122:NaN +# +122:inf:0 +inf:122:inf +122:-inf:0 +-inf:122:inf -inf:-inf:NaN -inf:inf:NaN -0:4:NaN +0:4:-inf -21:4:NaN 21:-21:NaN +# +0:-inf:NaN +0:-1:NaN +0:0:NaN +0:1:NaN +0:inf:NaN +# +1:-inf:0 +1:-1:0 +1:0:0 +1:1:NaN +1:4:0 +1:inf:0 +# +inf:-inf:NaN +inf:-1:NaN +inf:0:NaN +inf:1:NaN +inf:4:inf +inf:inf:NaN +# # normal results 1024:2:10 81:3:4 @@ -764,6 +793,7 @@ inf:inf:NaN 82:3:4 # 3.9... truncate 80:3:3 +4096:2:12 15625:5:6 15626:5:6 15624:5:5 @@ -781,7 +811,6 @@ inf:inf:NaN 144115188075855872:2:57 288230376151711744:2:58 576460752303423488:2:59 -4096:2:12 1329227995784915872903807060280344576:2:120 # $x == $base => result 1 3:3:1 @@ -2705,3 +2734,23 @@ NaNas_hex:NaN +inf:inf -inf:-inf NaNas_bin:NaN +# overloaded functions +&log +-1:NaN +0:-inf +1:0 +2:0 +3:1 +123456789:18 +1234567890987654321:41 +-inf:inf +inf:inf +NaN:NaN +&exp +&sin +&cos +&atan2 +&int +&neg +&abs +&sqrt diff --git a/cpan/Math-BigInt/t/bigintpm.t b/cpan/Math-BigInt/t/bigintpm.t index a03710e..b641ada 100644 --- a/cpan/Math-BigInt/t/bigintpm.t +++ b/cpan/Math-BigInt/t/bigintpm.t @@ -1,7 +1,7 @@ #!/usr/bin/perl -w use strict; -use Test::More tests => 3649 + 6; +use Test::More tests => 3701 + 6; use Math::BigInt lib => 'Calc'; diff --git a/cpan/Math-BigInt/t/biglog.t b/cpan/Math-BigInt/t/biglog.t index 7c3b618..94e8f73 100644 --- a/cpan/Math-BigInt/t/biglog.t +++ b/cpan/Math-BigInt/t/biglog.t @@ -20,14 +20,14 @@ use Math::BigInt; my $cl = "Math::BigInt"; ############################################################################# -# test log($n) in BigInt (broken until 1.80) +# test $n->blog() in BigInt (broken until 1.80) is ($cl->new(2)->blog(), '0', "blog(2)"); is ($cl->new(288)->blog(), '5',"blog(288)"); is ($cl->new(2000)->blog(), '7', "blog(2000)"); ############################################################################# -# test exp($n) in BigInt +# test $n->bexp() in BigInt is ($cl->new(1)->bexp(), '2', "bexp(1)"); is ($cl->new(2)->bexp(), '7',"bexp(2)"); @@ -38,7 +38,7 @@ is ($cl->new(3)->bexp(), '20', "bexp(3)"); # BigFloat tests ############################################################################# -# test log(2, N) where N > 67 (broken until 1.82) +# test $n->blog(undef, N) where N > 67 (broken until 1.82) $cl = "Math::BigFloat"; diff --git a/cpan/Math-BigInt/t/bigroot.t b/cpan/Math-BigInt/t/bigroot.t index c90d5ae..81532f9 100644 --- a/cpan/Math-BigInt/t/bigroot.t +++ b/cpan/Math-BigInt/t/bigroot.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!perl # Test broot function (and bsqrt() function, since it is used by broot()). @@ -8,7 +8,9 @@ # But it is better to test the numerical functionality, instead of not testing # it at all. -use strict; +use strict; # restrict unsafe constructs +use warnings; # enable optional warnings + use Test::More tests => 4 * 2; use Math::BigFloat; diff --git a/cpan/Math-BigInt/t/blog-mbf.t b/cpan/Math-BigInt/t/blog-mbf.t new file mode 100644 index 0000000..ec9e272 --- /dev/null +++ b/cpan/Math-BigInt/t/blog-mbf.t @@ -0,0 +1,264 @@ +#!perl + +BEGIN { + unless ($ENV{AUTHOR_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +use strict; +use warnings; + +use Test::More tests => 139; +use Scalar::Util qw< refaddr >; + +my $class; + +BEGIN { $class = 'Math::BigFloat'; } +BEGIN { use_ok($class) } + +while () { + s/\s+\z//; + next if /^#/ || ! /\S/; + + # $in0 - the x value + # $in1 - the base + # $out0 - the wanted output value + # $type - the type of the wanted number (real, non-real, ...) + # $expr - mathematical expression of the wanted number + + my ($in0, $in1, $out0, $type, $expr) = split /:/; + + # Some of the test data use rational numbers. + # - with Math::BigInt, we skip them + # - with Math::BigFloat, we convert them to floats + # - with Math::BigRat, we use them as they are + + $in0 = eval $in0 if $in0 =~ m|/|; + $in1 = eval $in1 if $in1 =~ m|/|; + $out0 = eval $out0 if $out0 =~ m|/|; + + my ($x, $y); # input values as objects + my ($yo); # copy of input value + my ($got); # test output + + my $test = qq|\$x = $class -> new("$in0"); | . + qq|\$y = $class -> new("$in1"); | . + qq|\$yo = \$y -> copy(); | . + qq|\$got = \$x -> blog(\$y);|; + + my $desc = "logarithm of $in0 to base $in1"; + + print("#\n", + "# Now about to execute the following test.\n", + "#\n", + "# $test\n", + "#\n"); + + if ($in0 ne 'NaN' && $in1 ne 'NaN') { + print("# Enter log($in1, $in0) into Wolfram Alpha", + " (http://www.wolframalpha.com/), and it says that the result", + " is ", length($type) ? $type : "real", + length($expr) ? ": $expr" : "", + ".", "\n", + "#\n"); + } + + eval $test; + die $@ if $@; # this should never happen + + subtest $desc, sub { + plan tests => 5, + + # Check output. + + is(ref($got), $class, "output arg is a $class"); + is($got, $out0, 'output arg has the right value'); + is(refaddr($got), refaddr($x), 'output arg is the invocand'); + + # The second argument (if the invocand is the first) shall *not* be + # modified. + + is(ref($y), $class, "second input arg is still a $class"); + is_deeply($y, $yo, 'second output arg is unmodified'); + + }; + +} + +__END__ + +# base = -inf + +-inf:-inf:NaN:undefined: +-4:-inf:0:: +-2:-inf:0:: +-1:-inf:0:: +-1/2:-inf:0:: +0:-inf:NaN:undefined: +1/2:-inf:0:: +1:-inf:0:: +2:-inf:0:: +4:-inf:0:: +inf:-inf:NaN:undefined: +NaN:-inf:NaN:undefined: + +# base = -4 + +-4:-4:1:: +-2:-4:NaN:non-real and finite:(log(2)+i pi)/(log(4)+i pi) +0:-4:NaN:non-real (directed) infinity:(-sqrt(pi^2+log^2(4))/(log(4)+i pi))infinity +1/2:-4:NaN:non-real and finite:-(log(2))/(log(4)+i pi) +1:-4:0:: +2:-4:NaN:non-real and finite:(log(2))/(log(4)+i pi) +4:-4:NaN:non-real and finite:(log(4))/(log(4)+i pi) +NaN:-4:NaN:undefined: + +# base = -2 + +-inf:-2:NaN:non-real (directed) infinity:sqrt(pi^2+log^2(2))/(log(2)+i pi)infinity +-4:-2:NaN:non-real and finite:(log(4)+i pi)/(log(2)+i pi) +-2:-2:1:: +-1:-2:NaN:non-real and finite:(i pi)/(log(2)+i pi) +-1/2:-2:NaN:non-real and finite:(-log(2)+i pi)/(log(2)+i pi) +0:-2:NaN:complex infinity: +1/2:-2:NaN:non-real and finite:-(log(2))/(log(2)+i pi) +1:-2:0:: +2:-2:NaN:non-real and finite:(log(2))/(log(2)+i pi) +4:-2:NaN:non-real and finite:(log(4))/(log(2)+i pi) +inf:-2:NaN:non-real (directed) infinity: +NaN:-2:NaN:undefined: + +# base = -1 + +-inf:-1:NaN:non-real (directed) infinity: +-4:-1:NaN:non-real and finite:-(i (log(4)+i pi))/pi +-2:-1:NaN:non-real and finite:-(i (log(2)+i pi))/pi +-1:-1:1:: +-1/2:-1:NaN:non-real and finite:-(i (-log(2)+i pi))/pi +0:-1:NaN:complex infinity: +1:-1:0:: +1/2:-1:NaN:non-real and finite:(i log(2))/pi +2:-1:NaN:non-real and finite:-(i log(2))/pi +4:-1:NaN:non-real and finite:-(i log(4))/pi +inf:-1:NaN:non-real (directed) infinity: +NaN:-1:NaN:undefined: + +# base = -1/2 + +-inf:-1/2:NaN:non-real (directed) infinity: +-4:-1/2:NaN:non-real and finite:(log(4)+i pi)/(-log(2)+i pi) +-2:-1/2:NaN:non-real and finite:(log(2)+i pi)/(-log(2)+i pi) +-1:-1/2:NaN:non-real and finite:(i pi)/(-log(2)+i pi) +-1/2:-1/2:1:: +0:-1/2:NaN:complex infinity: +1:-1/2:0:: +1/2:-1/2:NaN:non-real and finite:-(log(2))/(-log(2)+i pi) +2:-1/2:NaN:non-real and finite:(log(2))/(-log(2)+i pi) +4:-1/2:NaN:non-real and finite:(log(4))/(-log(2)+i pi) +inf:-1/2:NaN:non-real (directed) infinity: +NaN:-1/2:NaN:undefined: + +# base = 0 + +-inf:0:NaN:undefined: +-4:0:0:: +-2:0:0:: +-1:0:0:: +-1/2:0:0:: +0:0:NaN:undefined: +1/2:0:0:: +1:0:0:: +2:0:0:: +4:0:0:: +inf:0:NaN:undefined: +NaN:0:NaN:undefined: + +# base = 1/2 + +-inf:1/2:-inf:: +-2:-1/2:NaN:non-real and finite:(log(2)+i pi)/(-log(2)+i pi) +-1:1/2:NaN:non-real and finite:-(i pi)/(log(2)) +-1/2:1/2:NaN:non-real and finite:-(-log(2)+i pi)/(log(2)) +0:1/2:inf:: +1/2:1/2:1:: +1:1/2:0:: +2:1/2:-1:: +inf:1/2:-inf:: +NaN:1/2:NaN:undefined: + +# base = 1 + +-inf:1:NaN:complex infinity: +-4:1:NaN:complex infinity: +-2:1:NaN:complex infinity: +-1:1:NaN:complex infinity: +-1/2:1:NaN:complex infinity: +0:1:NaN:complex infinity: +1/2:1:NaN:complex infinity: +1:1:NaN:undefined: +2:1:NaN:complex infinity: +4:1:NaN:complex infinity: +inf:1:NaN:complex infinity: +NaN:1:NaN:undefined: + +# base = 2 + +-inf:2:inf:: +-4:2:NaN:non-real and finite:(log(4)+i pi)/(log(2)) +-2:2:NaN:non-real and finite:(log(2)+i pi)/(log(2)) +-1:2:NaN:non-real and finite:(i pi)/(log(2)) +-1/2:2:NaN:non-real and finite:(-log(2)+i pi)/(log(2)) +0:2:-inf:: +1/2:2:-1:: +1:2:0:: +2:2:1:: +4:2:2:: +4:4:1:: +inf:2:inf:: +NaN:2:NaN:undefined: + +# base = 4 + +-inf:4:inf:: +-4:4:NaN:non-real and finite:(log(4)+i pi)/(log(4)) +-2:4:NaN:non-real and finite:(log(2)+i pi)/(log(4)) +-1/2:4:NaN:non-real and finite:(-log(2)+i pi)/(log(4)) +0:4:-inf:: +1:4:0:: +1/2:4:-1/2:: +2:4:1/2:: +4:4:1:: +inf:4:inf:: +NaN:4:NaN:undefined: + +# base = inf + +-inf:inf:NaN:undefined: +-4:inf:0:: +-2:inf:0:: +-1:inf:0:: +-1/2:inf:0:: +0:inf:NaN:undefined: +1:inf:0:: +1/2:inf:0:: +2:inf:0:: +4:inf:0:: +inf:inf:NaN:undefined: +NaN:inf:NaN:undefined: + +# base is NaN + +-inf:NaN:NaN:undefined: +-4:NaN:NaN:undefined: +-2:NaN:NaN:undefined: +-1:NaN:NaN:undefined: +-1/2:NaN:NaN:undefined: +0:NaN:NaN:undefined: +1:NaN:NaN:undefined: +1/2:NaN:NaN:undefined: +2:NaN:NaN:undefined: +4:NaN:NaN:undefined: +inf:NaN:NaN:undefined: +NaN:NaN:NaN:undefined: diff --git a/cpan/Math-BigInt/t/blog-mbi.t b/cpan/Math-BigInt/t/blog-mbi.t new file mode 100644 index 0000000..5ca48c6 --- /dev/null +++ b/cpan/Math-BigInt/t/blog-mbi.t @@ -0,0 +1,264 @@ +#!perl + +BEGIN { + unless ($ENV{AUTHOR_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +use strict; +use warnings; + +use Test::More tests => 97; +use Scalar::Util qw< refaddr >; + +my $class; + +BEGIN { $class = 'Math::BigInt'; } +BEGIN { use_ok($class) } + +while () { + s/\s+\z//; + next if /^#/ || ! /\S/; + + # $in0 - the x value + # $in1 - the base + # $out0 - the wanted output value + # $type - the type of the wanted number (real, non-real, ...) + # $expr - mathematical expression of the wanted number + + my ($in0, $in1, $out0, $type, $expr) = split /:/; + + # Some of the test data use rational numbers. + # - with Math::BigInt, we skip them + # - with Math::BigFloat, we convert them to floats + # - with Math::BigRat, we use them as they are + + next if ($in0 =~ m|/| || + $in1 =~ m|/| || + $out0 =~ m|/|); + + my ($x, $y); # input values as objects + my ($yo); # copy of input value + my ($got); # test output + + my $test = qq|\$x = $class -> new("$in0"); | . + qq|\$y = $class -> new("$in1"); | . + qq|\$yo = \$y -> copy(); | . + qq|\$got = \$x -> blog(\$y);|; + + my $desc = "logarithm of $in0 to base $in1"; + + print("#\n", + "# Now about to execute the following test.\n", + "#\n", + "# $test\n", + "#\n"); + + if ($in0 ne 'NaN' && $in1 ne 'NaN') { + print("# Enter log($in1, $in0) into Wolfram Alpha", + " (http://www.wolframalpha.com/), and it says that the result", + " is ", length($type) ? $type : "real", + length($expr) ? ": $expr" : "", + ".", "\n", + "#\n"); + } + + eval $test; + die $@ if $@; # this should never happen + + subtest $desc, sub { + plan tests => 5, + + # Check output. + + is(ref($got), $class, "output arg is a $class"); + is($got, $out0, 'output arg has the right value'); + is(refaddr($got), refaddr($x), 'output arg is the invocand'); + + # The second argument (if the invocand is the first) shall *not* be + # modified. + + is(ref($y), $class, "second input arg is still a $class"); + is_deeply($y, $yo, 'second output arg is unmodified'); + + }; + +} + +__END__ + +# base = -inf + +-inf:-inf:NaN:undefined: +-4:-inf:0:: +-2:-inf:0:: +-1:-inf:0:: +-1/2:-inf:0:: +0:-inf:NaN:undefined: +1/2:-inf:0:: +1:-inf:0:: +2:-inf:0:: +4:-inf:0:: +inf:-inf:NaN:undefined: +NaN:-inf:NaN:undefined: + +# base = -4 + +-4:-4:1:: +-2:-4:NaN:non-real and finite:(log(2)+i pi)/(log(4)+i pi) +0:-4:NaN:non-real (directed) infinity:(-sqrt(pi^2+log^2(4))/(log(4)+i pi))infinity +1/2:-4:NaN:non-real and finite:-(log(2))/(log(4)+i pi) +1:-4:0:: +2:-4:NaN:non-real and finite:(log(2))/(log(4)+i pi) +4:-4:NaN:non-real and finite:(log(4))/(log(4)+i pi) +NaN:-4:NaN:undefined: + +# base = -2 + +-inf:-2:NaN:non-real (directed) infinity:sqrt(pi^2+log^2(2))/(log(2)+i pi)infinity +-4:-2:NaN:non-real and finite:(log(4)+i pi)/(log(2)+i pi) +-2:-2:1:: +-1:-2:NaN:non-real and finite:(i pi)/(log(2)+i pi) +-1/2:-2:NaN:non-real and finite:(-log(2)+i pi)/(log(2)+i pi) +0:-2:NaN:complex infinity: +1/2:-2:NaN:non-real and finite:-(log(2))/(log(2)+i pi) +1:-2:0:: +2:-2:NaN:non-real and finite:(log(2))/(log(2)+i pi) +4:-2:NaN:non-real and finite:(log(4))/(log(2)+i pi) +inf:-2:NaN:non-real (directed) infinity: +NaN:-2:NaN:undefined: + +# base = -1 + +-inf:-1:NaN:non-real (directed) infinity: +-4:-1:NaN:non-real and finite:-(i (log(4)+i pi))/pi +-2:-1:NaN:non-real and finite:-(i (log(2)+i pi))/pi +-1:-1:1:: +-1/2:-1:NaN:non-real and finite:-(i (-log(2)+i pi))/pi +0:-1:NaN:complex infinity: +1:-1:0:: +1/2:-1:NaN:non-real and finite:(i log(2))/pi +2:-1:NaN:non-real and finite:-(i log(2))/pi +4:-1:NaN:non-real and finite:-(i log(4))/pi +inf:-1:NaN:non-real (directed) infinity: +NaN:-1:NaN:undefined: + +# base = -1/2 + +-inf:-1/2:NaN:non-real (directed) infinity: +-4:-1/2:NaN:non-real and finite:(log(4)+i pi)/(-log(2)+i pi) +-2:-1/2:NaN:non-real and finite:(log(2)+i pi)/(-log(2)+i pi) +-1:-1/2:NaN:non-real and finite:(i pi)/(-log(2)+i pi) +-1/2:-1/2:1:: +0:-1/2:NaN:complex infinity: +1:-1/2:0:: +1/2:-1/2:NaN:non-real and finite:-(log(2))/(-log(2)+i pi) +2:-1/2:NaN:non-real and finite:(log(2))/(-log(2)+i pi) +4:-1/2:NaN:non-real and finite:(log(4))/(-log(2)+i pi) +inf:-1/2:NaN:non-real (directed) infinity: +NaN:-1/2:NaN:undefined: + +# base = 0 + +-inf:0:NaN:undefined: +-4:0:0:: +-2:0:0:: +-1:0:0:: +-1/2:0:0:: +0:0:NaN:undefined: +1/2:0:0:: +1:0:0:: +2:0:0:: +4:0:0:: +inf:0:NaN:undefined: +NaN:0:NaN:undefined: + +# base = 1/2 + +-inf:1/2:-inf:: +-2:-1/2:NaN:non-real and finite:(log(2)+i pi)/(-log(2)+i pi) +-1:1/2:NaN:non-real and finite:-(i pi)/(log(2)) +-1/2:1/2:NaN:non-real and finite:-(-log(2)+i pi)/(log(2)) +0:1/2:inf:: +1/2:1/2:1:: +1:1/2:0:: +2:1/2:-1:: +inf:1/2:-inf:: +NaN:1/2:NaN:undefined: + +# base = 1 + +-inf:1:NaN:complex infinity: +-4:1:NaN:complex infinity: +-2:1:NaN:complex infinity: +-1:1:NaN:complex infinity: +-1/2:1:NaN:complex infinity: +0:1:NaN:complex infinity: +1/2:1:NaN:complex infinity: +1:1:NaN:undefined: +2:1:NaN:complex infinity: +4:1:NaN:complex infinity: +inf:1:NaN:complex infinity: +NaN:1:NaN:undefined: + +# base = 2 + +-inf:2:inf:: +-4:2:NaN:non-real and finite:(log(4)+i pi)/(log(2)) +-2:2:NaN:non-real and finite:(log(2)+i pi)/(log(2)) +-1:2:NaN:non-real and finite:(i pi)/(log(2)) +-1/2:2:NaN:non-real and finite:(-log(2)+i pi)/(log(2)) +0:2:-inf:: +1/2:2:-1:: +1:2:0:: +2:2:1:: +4:2:2:: +4:4:1:: +inf:2:inf:: +NaN:2:NaN:undefined: + +# base = 4 + +-inf:4:inf:: +-4:4:NaN:non-real and finite:(log(4)+i pi)/(log(4)) +-2:4:NaN:non-real and finite:(log(2)+i pi)/(log(4)) +-1/2:4:NaN:non-real and finite:(-log(2)+i pi)/(log(4)) +0:4:-inf:: +1:4:0:: +1/2:4:-1/2:: +2:4:1/2:: +4:4:1:: +inf:4:inf:: +NaN:4:NaN:undefined: + +# base = inf + +-inf:inf:NaN:undefined: +-4:inf:0:: +-2:inf:0:: +-1:inf:0:: +-1/2:inf:0:: +0:inf:NaN:undefined: +1:inf:0:: +1/2:inf:0:: +2:inf:0:: +4:inf:0:: +inf:inf:NaN:undefined: +NaN:inf:NaN:undefined: + +# base is NaN + +-inf:NaN:NaN:undefined: +-4:NaN:NaN:undefined: +-2:NaN:NaN:undefined: +-1:NaN:NaN:undefined: +-1/2:NaN:NaN:undefined: +0:NaN:NaN:undefined: +1:NaN:NaN:undefined: +1/2:NaN:NaN:undefined: +2:NaN:NaN:undefined: +4:NaN:NaN:undefined: +inf:NaN:NaN:undefined: +NaN:NaN:NaN:undefined: diff --git a/cpan/Math-BigInt/t/mbimbf.t b/cpan/Math-BigInt/t/mbimbf.t index 7d8afb0..89559a2 100644 --- a/cpan/Math-BigInt/t/mbimbf.t +++ b/cpan/Math-BigInt/t/mbimbf.t @@ -7,8 +7,8 @@ use strict; use Test::More tests => 684 + 26; # own tests -use Math::BigInt 1.70; -use Math::BigFloat 1.43; +use Math::BigInt lib => 'Calc'; +use Math::BigFloat; use vars qw/$mbi $mbf/; diff --git a/cpan/Math-BigInt/t/objectify_mbf.t b/cpan/Math-BigInt/t/objectify_mbf.t new file mode 100644 index 0000000..a91ad4b --- /dev/null +++ b/cpan/Math-BigInt/t/objectify_mbf.t @@ -0,0 +1,90 @@ +#!perl +# +# Verify that objectify() is able to convert a "foreign" object into what we +# want, when what we want is Math::BigFloat or subclass thereof. + +use strict; +use warnings; + +package main; + +use Test::More tests => 6; + +use Math::BigFloat; + +############################################################################### + +for my $class ('Math::BigFloat', 'Math::BigFloat::Subclass') { + + # This object defines what we want. + + my $float = $class -> new(10); + + # Create various objects that should work with the object above after + # objectify() has done its thing. + + my $float_percent1 = My::Percent::Float1 -> new(100); + is($float * $float_percent1, 10); + + my $float_percent2 = My::Percent::Float2 -> new(100); + is($float * $float_percent2, 10); + + my $float_percent3 = My::Percent::Float3 -> new(100); + is($float * $float_percent3, 10); +} + +############################################################################### +# Class supports as_float(), which returns a Math::BigFloat. + +package My::Percent::Float1; + +sub new { + my $class = shift; + my $num = shift; + return bless \$num, $class; +} + +sub as_float { + my $self = shift; + return Math::BigFloat -> new($$self / 100); +} + +############################################################################### +# Class supports as_float(), which returns a scalar. + +package My::Percent::Float2; + +sub new { + my $class = shift; + my $num = shift; + return bless \$num, $class; +} + +sub as_float { + my $self = shift; + return $$self / 100; +} + +############################################################################### +# Class does not support as_float(). + +package My::Percent::Float3; + +use overload '""' => sub { $_[0] -> as_string(); }; + +sub new { + my $class = shift; + my $num = shift; + return bless \$num, $class; +} + +sub as_string { + my $self = shift; + return $$self / 100; +} + +############################################################################### + +package Math::BigFloat::Subclass; + +use base 'Math::BigFloat'; diff --git a/cpan/Math-BigInt/t/objectify_mbi.t b/cpan/Math-BigInt/t/objectify_mbi.t new file mode 100644 index 0000000..155dd52 --- /dev/null +++ b/cpan/Math-BigInt/t/objectify_mbi.t @@ -0,0 +1,130 @@ +#!perl +# +# Verify that objectify() is able to convert a "foreign" object into what we +# want, when what we want is Math::BigInt or subclass thereof. + +use strict; +use warnings; + +package main; + +use Test::More tests => 10; + +use Math::BigInt; + +############################################################################### + +for my $class ('Math::BigInt', 'Math::BigInt::Subclass') { + + # This object defines what we want. + + my $int = $class -> new(10); + + # Create various objects that should work with the object above after + # objectify() has done its thing. + + my $int_percent1 = My::Percent::Int1 -> new(100); + is($int * $int_percent1, 10); + + my $int_percent2 = My::Percent::Int2 -> new(100); + is($int * $int_percent2, 10); + + my $int_percent3 = My::Percent::Int3 -> new(100); + is($int * $int_percent3, 10); + + my $int_percent4 = My::Percent::Int4 -> new(100); + is($int * $int_percent4, 10); + + my $int_percent5 = My::Percent::Int5 -> new(100); + is($int * $int_percent5, 10); +} + +############################################################################### +# Class supports as_int(), which returns a Math::BigInt. + +package My::Percent::Int1; + +sub new { + my $class = shift; + my $num = shift; + return bless \$num, $class; +} + +sub as_int { + my $self = shift; + return Math::BigInt -> new($$self / 100); +} + +############################################################################### +# Class supports as_int(), which returns a scalar. + +package My::Percent::Int2; + +sub new { + my $class = shift; + my $num = shift; + return bless \$num, $class; +} + +sub as_int { + my $self = shift; + return $$self / 100; +} + +############################################################################### +# Class does not support as_int(), but supports as_number(), which returns a +# Math::BigInt. + +package My::Percent::Int3; + +sub new { + my $class = shift; + my $num = shift; + return bless \$num, $class; +} + +sub as_number { + my $self = shift; + return Math::BigInt -> new($$self / 100); +} + +############################################################################### +# Class does not support as_int(), but supports as_number(), which returns a +# scalar. + +package My::Percent::Int4; + +sub new { + my $class = shift; + my $num = shift; + return bless \$num, $class; +} + +sub as_number { + my $self = shift; + return $$self / 100; +} + +############################################################################### +# Class supports neither as_int() or as_number(). + +package My::Percent::Int5; + +use overload '""' => sub { $_[0] -> as_string(); }; + +sub new { + my $class = shift; + my $num = shift; + return bless \$num, $class; +} + +sub as_string { + my $self = shift; + return $$self / 100; +} + +############################################################################### + +package Math::BigInt::Subclass; + +use base 'Math::BigInt'; diff --git a/cpan/Math-BigInt/t/sub_mbf.t b/cpan/Math-BigInt/t/sub_mbf.t index fec4d07..035b129 100644 --- a/cpan/Math-BigInt/t/sub_mbf.t +++ b/cpan/Math-BigInt/t/sub_mbf.t @@ -1,7 +1,7 @@ #!/usr/bin/perl -w use strict; -use Test::More tests => 2340 +use Test::More tests => 2360 + 6; # + our own tests diff --git a/cpan/Math-BigInt/t/sub_mbi.t b/cpan/Math-BigInt/t/sub_mbi.t index b8e0a02..1af9f1c 100644 --- a/cpan/Math-BigInt/t/sub_mbi.t +++ b/cpan/Math-BigInt/t/sub_mbi.t @@ -1,7 +1,7 @@ #!/usr/bin/perl -w use strict; -use Test::More tests => 3649 +use Test::More tests => 3701 + 5; # +5 own tests BEGIN { unshift @INC, 't'; } diff --git a/cpan/Math-BigInt/t/with_sub.t b/cpan/Math-BigInt/t/with_sub.t index d90bbbc..86c7684 100644 --- a/cpan/Math-BigInt/t/with_sub.t +++ b/cpan/Math-BigInt/t/with_sub.t @@ -3,7 +3,7 @@ # Test use Math::BigFloat with => 'Math::BigInt::SomeSubclass'; use strict; -use Test::More tests => 2340 + 1; +use Test::More tests => 2360 + 1; use Math::BigFloat with => 'Math::BigInt::Subclass', lib => 'Calc'; diff --git a/cpan/Module-Metadata/lib/Module/Metadata.pm b/cpan/Module-Metadata/lib/Module/Metadata.pm index 2fa75c1..3fa404e 100644 --- a/cpan/Module-Metadata/lib/Module/Metadata.pm +++ b/cpan/Module-Metadata/lib/Module/Metadata.pm @@ -1,6 +1,7 @@ # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- # vim:ts=8:sw=2:et:sta:sts=2 -package Module::Metadata; # git description: v1.000026-12-g9b12bf1 +package Module::Metadata; # git description: v1.000028-4-gb283720 +# ABSTRACT: Gather package and POD information from perl module files # Adapted from Perl-licensed code originally distributed with # Module-Build by Ken Williams @@ -13,7 +14,7 @@ sub __clean_eval { eval $_[0] } use strict; use warnings; -our $VERSION = '1.000027'; +our $VERSION = '1.000029'; # TRIAL use Carp qw/croak/; use File::Spec; @@ -30,7 +31,8 @@ BEGIN { Log::Contextual->import('log_info', '-default_logger' => Log::Contextual::WarnLogger->new({ env_prefix => 'MODULE_METADATA', }), ); - } else { + } + else { *log_info = sub (&) { warn $_[0]->() }; } } @@ -173,10 +175,12 @@ sub new_from_module { if ( defined( $version ) ) { if ( $compare_versions->( $version, '!=', $p->{version} ) ) { $err .= " $p->{file} ($p->{version})\n"; - } else { + } + else { # same version declared multiple times, ignore } - } else { + } + else { $file = $p->{file}; $version = $p->{version}; } @@ -242,7 +246,8 @@ sub new_from_module { if ( $files ) { @files = @$files; - } else { + } + else { find( { wanted => sub { push @files, $_ if -f $_ && /\.pm$/; @@ -272,12 +277,14 @@ sub new_from_module { if ( $package eq $prime_package ) { if ( exists( $prime{$package} ) ) { croak "Unexpected conflict in '$package'; multiple versions found.\n"; - } else { + } + else { $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename); $prime{$package}{file} = $mapped_filename; $prime{$package}{version} = $version if defined( $version ); } - } else { + } + else { push( @{$alt{$package}}, { file => $mapped_filename, version => $version, @@ -304,7 +311,8 @@ sub new_from_module { $result->{err} }; - } elsif ( defined( $result->{version} ) ) { + } + elsif ( defined( $result->{version} ) ) { # There is a primary package selected, and exactly one # alternative package @@ -324,19 +332,22 @@ sub new_from_module { }; } - } else { + } + else { # The prime package selected has no version so, we choose to # use any alternative package that does have a version $prime{$package}{file} = $result->{file}; $prime{$package}{version} = $result->{version}; } - } else { + } + else { # no alt package found with a version, but we have a prime # package so we use it whether it has a version or not } - } else { # No primary package was selected, use the best alternative + } + else { # No primary package was selected, use the best alternative if ( $result->{err} ) { log_info { @@ -408,17 +419,12 @@ sub _init { $self->{module} = shift(@candidates); # punt } else { - if(grep /main/, @{$self->{packages}}) { - $self->{module} = 'main'; - } - else { - $self->{module} = $self->{packages}[0] || ''; - } + $self->{module} = 'main'; } } $self->{version} = $self->{versions}{$self->{module}} - if defined( $self->{module} ); + if defined( $self->{module} ); return $self; } @@ -487,9 +493,11 @@ sub _handle_bom { my $encoding; if ( $buf eq "\x{FE}\x{FF}" ) { $encoding = 'UTF-16BE'; - } elsif ( $buf eq "\x{FF}\x{FE}" ) { + } + elsif ( $buf eq "\x{FF}\x{FE}" ) { $encoding = 'UTF-16LE'; - } elsif ( $buf eq "\x{EF}\x{BB}" ) { + } + elsif ( $buf eq "\x{EF}\x{BB}" ) { $buf = ' '; $count = read $fh, $buf, length $buf; if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) { @@ -501,7 +509,8 @@ sub _handle_bom { if ( "$]" >= 5.008 ) { binmode( $fh, ":encoding($encoding)" ); } - } else { + } + else { seek $fh, $pos, SEEK_SET or croak( sprintf "Can't reset position to the top of '$filename'" ); } @@ -544,88 +553,91 @@ sub _parse_fh { $pod_data = ''; } $pod_sect = $1; - - } elsif ( $self->{collect_pod} ) { + } + elsif ( $self->{collect_pod} ) { $pod_data .= "$line\n"; - } - - } elsif ( $is_cut ) { - + next; + } + elsif ( $is_cut ) { if ( $self->{collect_pod} && length( $pod_data ) ) { $pod{$pod_sect} = $pod_data; $pod_data = ''; } $pod_sect = ''; + next; + } - } else { + # Skip after __END__ + next if $in_end; - # Skip after __END__ - next if $in_end; + # Skip comments in code + next if $line =~ /^\s*#/; - # Skip comments in code - next if $line =~ /^\s*#/; + # Would be nice if we could also check $in_string or something too + if ($line eq '__END__') { + $in_end++; + next; + } - # Would be nice if we could also check $in_string or something too - if ($line eq '__END__') { - $in_end++; - next; + last if $line eq '__DATA__'; + + # parse $line to see if it's a $VERSION declaration + my( $version_sigil, $version_fullname, $version_package ) = + index($line, 'VERSION') >= 1 + ? $self->_parse_version_expression( $line ) + : (); + + if ( $line =~ /$PKG_REGEXP/o ) { + $package = $1; + my $version = $2; + push( @packages, $package ) unless grep( $package eq $_, @packages ); + $need_vers = defined $version ? 0 : 1; + + if ( not exists $vers{$package} and defined $version ){ + # Upgrade to a version object. + my $dwim_version = eval { _dwim_version($version) }; + croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n" + unless defined $dwim_version; # "0" is OK! + $vers{$package} = $dwim_version; } - last if $line eq '__DATA__'; - - # parse $line to see if it's a $VERSION declaration - my( $version_sigil, $version_fullname, $version_package ) = - index($line, 'VERSION') >= 1 - ? $self->_parse_version_expression( $line ) - : (); - - if ( $line =~ /$PKG_REGEXP/o ) { - $package = $1; - my $version = $2; - push( @packages, $package ) unless grep( $package eq $_, @packages ); - $need_vers = defined $version ? 0 : 1; - - if ( not exists $vers{$package} and defined $version ){ - # Upgrade to a version object. - my $dwim_version = eval { _dwim_version($version) }; - croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n" - unless defined $dwim_version; # "0" is OK! - $vers{$package} = $dwim_version; - } + } - # VERSION defined with full package spec, i.e. $Module::VERSION - } elsif ( $version_fullname && $version_package ) { - push( @packages, $version_package ) unless grep( $version_package eq $_, @packages ); - $need_vers = 0 if $version_package eq $package; + # VERSION defined with full package spec, i.e. $Module::VERSION + elsif ( $version_fullname && $version_package ) { + # we do NOT save this package in found @packages + $need_vers = 0 if $version_package eq $package; - unless ( defined $vers{$version_package} && length $vers{$version_package} ) { + unless ( defined $vers{$version_package} && length $vers{$version_package} ) { $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); } + } - # first non-comment line in undeclared package main is VERSION - } elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) { - $need_vers = 0; - my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); - $vers{$package} = $v; - push( @packages, 'main' ); + # first non-comment line in undeclared package main is VERSION + elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) { + $need_vers = 0; + my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); + $vers{$package} = $v; + push( @packages, 'main' ); + } - # first non-comment line in undeclared package defines package main - } elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) { - $need_vers = 1; - $vers{main} = ''; - push( @packages, 'main' ); + # first non-comment line in undeclared package defines package main + elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) { + $need_vers = 1; + $vers{main} = ''; + push( @packages, 'main' ); + } - # only keep if this is the first $VERSION seen - } elsif ( $version_fullname && $need_vers ) { - $need_vers = 0; - my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); + # only keep if this is the first $VERSION seen + elsif ( $version_fullname && $need_vers ) { + $need_vers = 0; + my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); - unless ( defined $vers{$package} && length $vers{$package} ) { - $vers{$package} = $v; - } + unless ( defined $vers{$package} && length $vers{$package} ) { + $vers{$package} = $v; } } - } + } # end loop over each line if ( $self->{collect_pod} && length($pod_data) ) { $pod{$pod_sect} = $pod_data; @@ -652,7 +664,8 @@ sub _evaluate_version_line { sub { local $sigil$variable_name; $line; - \$$variable_name + return \$$variable_name if defined \$$variable_name; + return \$Module::Metadata::_version::p${pn}::$variable_name; }; }; @@ -763,7 +776,8 @@ sub version { if ( defined( $mod ) && length( $mod ) && exists( $self->{versions}{$mod} ) ) { return $self->{versions}{$mod}; - } else { + } + else { return undef; } } @@ -774,7 +788,8 @@ sub pod { if ( defined( $sect ) && length( $sect ) && exists( $self->{pod}{$sect} ) ) { return $self->{pod}{$sect}; - } else { + } + else { return undef; } } @@ -793,10 +808,20 @@ sub is_indexable { 1; +__END__ + +=pod + +=encoding UTF-8 + =head1 NAME Module::Metadata - Gather package and POD information from perl module files +=head1 VERSION + +version 1.000029 + =head1 SYNOPSIS use Module::Metadata; @@ -996,11 +1021,24 @@ Returns the POD data in the given section. =head2 C<< is_indexable($package) >> or C<< is_indexable() >> +Available since version 1.000020. + Returns a boolean indicating whether the package (if provided) or any package (otherwise) is eligible for indexing by PAUSE, the Perl Authors Upload Server. Note This only checks for valid C declarations, and does not take any ownership information into account. +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +There is also a mailing list available for users of this distribution, at +http://lists.perl.org/list/cpan-workers.html. + +There is also an irc channel available for users of this distribution, at +irc://irc.perl.org/#toolchain. + =head1 AUTHOR Original code from Module::Build::ModuleInfo by Ken Williams @@ -1009,6 +1047,98 @@ Original code from Module::Build::ModuleInfo by Ken Williams Released as Module::Metadata by Matt S Trout (mst) with assistance from David Golden (xdg) . +=head1 CONTRIBUTORS + +=for stopwords Karen Etheridge David Golden Vincent Pit Matt S Trout Chris Nehren Graham Knop Olivier Mengué Tomas Doran Tatsuhiko Miyagawa tokuhirom Peter Rabbitson Jerry D. Hedden Craig A. Berry Mitchell Steinbrunner Edward Zborowski Gareth Harper James Raspass 'BinGOs' Williams Josh Jore Kent Fredric + +=over 4 + +=item * + +Karen Etheridge + +=item * + +David Golden + +=item * + +Vincent Pit + +=item * + +Matt S Trout + +=item * + +Chris Nehren + +=item * + +Graham Knop + +=item * + +Olivier Mengué + +=item * + +Tomas Doran + +=item * + +Tatsuhiko Miyagawa + +=item * + +tokuhirom + +=item * + +Peter Rabbitson + +=item * + +Jerry D. Hedden + +=item * + +Craig A. Berry + +=item * + +David Mitchell + +=item * + +David Steinbrunner + +=item * + +Edward Zborowski + +=item * + +Gareth Harper + +=item * + +James Raspass + +=item * + +Chris 'BinGOs' Williams + +=item * + +Josh Jore + +=item * + +Kent Fredric + +=back + =head1 COPYRIGHT & LICENSE Original code Copyright (c) 2001-2011 Ken Williams. diff --git a/cpan/Module-Metadata/t/extract-package.t b/cpan/Module-Metadata/t/extract-package.t new file mode 100644 index 0000000..640b239 --- /dev/null +++ b/cpan/Module-Metadata/t/extract-package.t @@ -0,0 +1,146 @@ +use strict; +use warnings; +# vim:ts=8:sw=2:et:sta:sts=2 + +use Test::More 0.82; +use Module::Metadata; + +use lib 't/lib'; +use GeneratePackage; + +# parse package names +# format: { +# name => test name +# code => code snippet (string) +# package => expected package names +# } +my @pkg_names = ( +{ + name => 'package NAME', + package => [ 'Simple' ], + code => <<'---', +package Simple; +--- +}, +{ + name => 'package NAME::SUBNAME', + package => [ 'Simple::Edward' ], + code => <<'---', +package Simple::Edward; +--- +}, +{ + name => 'package NAME::SUBNAME::', + package => [ 'Simple::Edward::' ], + code => <<'---', +package Simple::Edward::; +--- +}, +{ + name => "package NAME'SUBNAME", + package => [ "Simple'Edward" ], + code => <<'---', +package Simple'Edward; +--- +}, +{ + name => "package NAME'SUBNAME::", + package => [ "Simple'Edward::" ], + code => <<'---', +package Simple'Edward::; +--- +}, +{ + name => 'package NAME::::SUBNAME', + package => [ 'Simple::::Edward' ], + code => <<'---', +package Simple::::Edward; +--- +}, +{ + name => 'package ::NAME::SUBNAME', + package => [ '::Simple::Edward' ], + code => <<'---', +package ::Simple::Edward; +--- +}, +{ + name => 'package NAME:SUBNAME (fail)', + package => [ 'main' ], + code => <<'---', +package Simple:Edward; +--- +}, +{ + name => "package NAME' (fail)", + package => [ 'main' ], + code => <<'---', +package Simple'; +--- +}, +{ + name => "package NAME::SUBNAME' (fail)", + package => [ 'main' ], + code => <<'---', +package Simple::Edward'; +--- +}, +{ + name => "package NAME''SUBNAME (fail)", + package => [ 'main' ], + code => <<'---', +package Simple''Edward; +--- +}, +{ + name => 'package NAME-SUBNAME (fail)', + package => [ 'main' ], + code => <<'---', +package Simple-Edward; +--- +}, +{ + name => 'no assumption of package merely if its $VERSION is referenced', + package => [ 'Simple' ], + code => <<'---', +package Simple; +$Foo::Bar::VERSION = '1.23'; +--- +}, +); + +my $test_num = 0; + +my $tmpdir = GeneratePackage::tmpdir(); + +foreach my $test_case (@pkg_names) { + note '-------'; + note $test_case->{name}; + my $code = $test_case->{code}; + my $expected_name = $test_case->{package}; + local $TODO = $test_case->{TODO}; + + my $warnings = ''; + local $SIG{__WARN__} = sub { $warnings .= $_ for @_ }; + + my $pm_info = Module::Metadata->new_from_file(generate_file(File::Spec->catdir($tmpdir, "Simple${test_num}"), 'Simple.pm', $code)); + + # whenever we drop support for 5.6, we can do this: + # open my $fh, '<', \(encode('UTF-8', $code, Encode::FB_CROAK)) + # or die "cannot open handle to code string: $!"; + # my $pm_info = Module::Metadata->new_from_handle($fh, 'lib/Simple.pm'); + + # Test::Builder will prematurely numify objects, so use this form + my $errs; + my @got = $pm_info->packages_inside(); + is_deeply( \@got, $expected_name, + "case $test_case->{name}: correct package names (expected '" . join(', ', @$expected_name) . "')" ) + or $errs++; + is( $warnings, '', "case $test_case->{name}: no warnings from parsing" ) or $errs++; + diag "Got: '" . join(', ', @got) . "'\nModule contents:\n$code" if $errs; +} +continue { + ++$test_num; +} + +done_testing; diff --git a/cpan/Module-Metadata/t/extract-version.t b/cpan/Module-Metadata/t/extract-version.t new file mode 100644 index 0000000..3329aa1 --- /dev/null +++ b/cpan/Module-Metadata/t/extract-version.t @@ -0,0 +1,683 @@ +use strict; +use warnings; +# vim:ts=8:sw=2:et:sta:sts=2 + +use Test::More 0.82; +use Data::Dumper; +use Module::Metadata; + +use lib 't/lib'; +use GeneratePackage; + +my $undef; + +# parse various module $VERSION lines +# format: { +# name => test name +# code => code snippet (string) +# vers => expected version object (in stringified form), +# } +my @modules = ( +{ + vers => $undef, + all_versions => {}, + name => 'no $VERSION line', + code => <<'---', +package Simple; +--- +}, +{ + vers => $undef, + all_versions => {}, + name => 'undefined $VERSION', + code => <<'---', +package Simple; +our $VERSION; +--- +}, +{ + vers => '1.23', + all_versions => { Simple => '1.23' }, + name => 'declared & defined on same line with "our"', + code => <<'---', +package Simple; +our $VERSION = '1.23'; +--- +}, +{ + vers => '1.23', + all_versions => { Simple => '1.23' }, + name => 'declared & defined on separate lines with "our"', + code => <<'---', +package Simple; +our $VERSION; +$VERSION = '1.23'; +--- +}, +{ + name => 'commented & defined on same line', + code => <<'---', +package Simple; +our $VERSION = '1.23'; # our $VERSION = '4.56'; +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => 'commented & defined on separate lines', + code => <<'---', +package Simple; +# our $VERSION = '4.56'; +our $VERSION = '1.23'; +--- + vers =>'1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => 'use vars', + code => <<'---', +package Simple; +use vars qw( $VERSION ); +$VERSION = '1.23'; +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => 'choose the right default package based on package/file name', + code => <<'---', +package Simple::_private; +$VERSION = '0'; +package Simple; +$VERSION = '1.23'; # this should be chosen for version +--- + vers => '1.23', + all_versions => { 'Simple' => '1.23', 'Simple::_private' => '0' }, +}, +{ + name => 'just read the first $VERSION line', + code => <<'---', +package Simple; +$VERSION = '1.23'; # we should see this line +$VERSION = eval $VERSION; # and ignore this one +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => 'just read the first $VERSION line in reopened package (1)', + code => <<'---', +package Simple; +$VERSION = '1.23'; +package Error::Simple; +$VERSION = '2.34'; +package Simple; +--- + vers => '1.23', + all_versions => { 'Error::Simple' => '2.34', Simple => '1.23' }, +}, +{ + name => 'just read the first $VERSION line in reopened package (2)', + code => <<'---', +package Simple; +package Error::Simple; +$VERSION = '2.34'; +package Simple; +$VERSION = '1.23'; +--- + vers => '1.23', + all_versions => { 'Error::Simple' => '2.34', Simple => '1.23' }, +}, +{ + name => 'mentions another module\'s $VERSION', + code => <<'---', +package Simple; +$VERSION = '1.23'; +if ( $Other::VERSION ) { + # whatever +} +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => 'mentions another module\'s $VERSION in a different package', + code => <<'---', +package Simple; +$VERSION = '1.23'; +package Simple2; +if ( $Simple::VERSION ) { + # whatever +} +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => '$VERSION checked only in assignments, not regexp ops', + code => <<'---', +package Simple; +$VERSION = '1.23'; +if ( $VERSION =~ /1\.23/ ) { + # whatever +} +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => '$VERSION checked only in assignments, not relational ops (1)', + code => <<'---', +package Simple; +$VERSION = '1.23'; +if ( $VERSION == 3.45 ) { + # whatever +} +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => '$VERSION checked only in assignments, not relational ops (2)', + code => <<'---', +package Simple; +$VERSION = '1.23'; +package Simple2; +if ( $Simple::VERSION == 3.45 ) { + # whatever +} +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => 'Fully qualified $VERSION declared in package', + code => <<'---', +package Simple; +$Simple::VERSION = 1.23; +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => 'Differentiate fully qualified $VERSION in a package', + code => <<'---', +package Simple; +$Simple2::VERSION = '999'; +$Simple::VERSION = 1.23; +--- + vers => '1.23', + all_versions => { Simple => '1.23', Simple2 => '999' }, +}, +{ + name => 'Differentiate fully qualified $VERSION and unqualified', + code => <<'---', +package Simple; +$Simple2::VERSION = '999'; +$VERSION = 1.23; +--- + vers => '1.23', + all_versions => { Simple => '1.23', Simple2 => '999' }, +}, +{ + name => 'Differentiate fully qualified $VERSION and unqualified, other order', + code => <<'---', +package Simple; +$VERSION = 1.23; +$Simple2::VERSION = '999'; +--- + vers => '1.23', + all_versions => { Simple => '1.23', Simple2 => '999' }, +}, +{ + name => '$VERSION declared as package variable from within "main" package', + code => <<'---', +$Simple::VERSION = '1.23'; +{ + package Simple; + $x = $y, $cats = $dogs; +} +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => '$VERSION wrapped in parens - space inside', + code => <<'---', +package Simple; +( $VERSION ) = '1.23'; +--- + '1.23' => <<'---', # $VERSION wrapped in parens - no space inside +package Simple; +($VERSION) = '1.23'; +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => '$VERSION follows a spurious "package" in a quoted construct', + code => <<'---', +package Simple; +__PACKAGE__->mk_accessors(qw( + program socket proc + package filename line codeline subroutine finished)); + +our $VERSION = "1.23"; +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => '$VERSION using version.pm', + code => <<'---', + package Simple; + use version; our $VERSION = version->new('1.23'); +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => '$VERSION using version.pm and qv()', + code => <<'---', + package Simple; + use version; our $VERSION = qv('1.230'); +--- + vers => 'v1.230', + all_versions => { Simple => 'v1.230' }, +}, +{ + name => 'underscore version with an eval', + code => <<'---', + package Simple; + $VERSION = '1.23_01'; + $VERSION = eval $VERSION; +--- + vers => '1.23_01', + all_versions => { Simple => '1.23_01' }, +}, +{ + name => 'Two version assignments, no package', + code => <<'---', + $Simple::VERSION = '1.230'; + $Simple::VERSION = eval $Simple::VERSION; +--- + vers => $undef, + all_versions => { Simple => '1.230' }, +}, +{ + name => 'Two version assignments, should ignore second one', + code => <<'---', +package Simple; + $Simple::VERSION = '1.230'; + $Simple::VERSION = eval $Simple::VERSION; +--- + vers => '1.230', + all_versions => { Simple => '1.230' }, +}, +{ + name => 'declared & defined on same line with "our"', + code => <<'---', +package Simple; +our $VERSION = '1.23_00_00'; +--- + vers => '1.230000', + all_versions => { Simple => '1.230000' }, +}, +{ + name => 'package NAME VERSION', + code => <<'---', + package Simple 1.23; +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => 'package NAME VERSION', + code => <<'---', + package Simple 1.23_01; +--- + vers => '1.23_01', + all_versions => { Simple => '1.23_01' }, +}, +{ + name => 'package NAME VERSION', + code => <<'---', + package Simple v1.2.3; +--- + vers => 'v1.2.3', + all_versions => { Simple => 'v1.2.3' }, +}, +{ + name => 'package NAME VERSION', + code => <<'---', + package Simple v1.2_3; +--- + vers => 'v1.2_3', + all_versions => { Simple => 'v1.2_3' }, +}, +{ + name => 'trailing crud', + code => <<'---', + package Simple; + our $VERSION; + $VERSION = '1.23-alpha'; +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => 'trailing crud', + code => <<'---', + package Simple; + our $VERSION; + $VERSION = '1.23b'; +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => 'multi_underscore', + code => <<'---', + package Simple; + our $VERSION; + $VERSION = '1.2_3_4'; +--- + vers => '1.234', + all_versions => { Simple => '1.234' }, +}, +{ + name => 'non-numeric', + code => <<'---', + package Simple; + our $VERSION; + $VERSION = 'onetwothree'; +--- + vers => '0', + all_versions => { Simple => '0' }, +}, +{ + name => 'package NAME BLOCK, undef $VERSION', + code => <<'---', +package Simple { + our $VERSION; +} +--- + vers => $undef, + all_versions => {}, +}, +{ + name => 'package NAME BLOCK, with $VERSION', + code => <<'---', +package Simple { + our $VERSION = '1.23'; +} +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => 'package NAME VERSION BLOCK (1)', + code => <<'---', +package Simple 1.23 { + 1; +} +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, +}, +{ + name => 'package NAME VERSION BLOCK (2)', + code => <<'---', +package Simple v1.2.3_4 { + 1; +} +--- + vers => 'v1.2.3_4', + all_versions => { Simple => 'v1.2.3_4' }, +}, +{ + name => 'set from separately-initialised variable, two lines', + code => <<'---', +package Simple; + our $CVSVERSION = '$Revision: 1.7 $'; + our ($VERSION) = ($CVSVERSION =~ /(\d+\.\d+)/); +} +--- + vers => '0', + all_versions => { Simple => '0' }, +}, +{ + name => 'our + bare v-string', + code => <<'---', +package Simple; +our $VERSION = v2.2.102.2; +--- + vers => 'v2.2.102.2', + all_versions => { Simple => 'v2.2.102.2' }, +}, +{ + name => 'our + dev release', + code => <<'---', +package Simple; +our $VERSION = "0.0.9_1"; +--- + vers => '0.0.9_1', + all_versions => { Simple => '0.0.9_1' }, +}, +{ + name => 'our + crazy string and substitution code', + code => <<'---', +package Simple; +our $VERSION = '1.12.B55J2qn'; our $WTF = $VERSION; $WTF =~ s/^\d+\.\d+\.//; # attempts to rationalize $WTF go here. +--- + vers => '1.12', + all_versions => { Simple => '1.12' }, +}, +{ + name => 'our in braces, as in Dist::Zilla::Plugin::PkgVersion with use_our = 1', + code => <<'---', +package Simple; +{ our $VERSION = '1.12'; } +--- + vers => '1.12', + all_versions => { Simple => '1.12' }, +}, +{ + name => 'calculated version - from Acme-Pi-3.14', + code => <<'---', +package Simple; +my $version = atan2(1,1) * 4; $Simple::VERSION = "$version"; +1; +--- + vers => sub { defined $_[0] and $_[0] =~ /^3\.14159/ }, + all_versions => sub { ref $_[0] eq 'HASH' + and keys %{$_[0]} == 1 + and (keys%{$_[0]})[0] eq 'Simple' + and (values %{$_[0]})[0] =~ /^3\.14159/ + }, +}, +{ + name => 'set from separately-initialised variable, one line', + code => <<'---', +package Simple; + my $CVSVERSION = '$Revision: 1.7 $'; our ($VERSION) = ($CVSVERSION =~ /(\d+\.\d+)/); +} +--- + vers => '1.7', + all_versions => { Simple => '1.7' }, +}, +{ + name => 'from Lingua-StopWords-0.09/devel/gen_modules.plx', + code => <<'---', +package Foo; +our $VERSION = $Bar::VERSION; +--- + vers => $undef, + all_versions => { Foo => '0' }, +}, +{ + name => 'from XML-XSH2-2.1.17/lib/XML/XSH2/Parser.pm', + code => <<'---', +our $VERSION = # Hide from PAUSE + '1.967009'; +$VERSION = eval $VERSION; +--- + vers => $undef, + all_versions => { main => '0' }, +}, +{ + name => 'from MBARBON/Module-Info-0.30.tar.gz', + code => <<'---', +package Simple; +$VERSION = eval 'use version; 1' ? 'version'->new('0.30') : '0.30'; +--- + vers => '0.30', + all_versions => { Simple => '0.30' }, +}, +{ + name => '$VERSION inside BEGIN block', + code => <<'---', +package Simple; + BEGIN { $VERSION = '1.23' } +} +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, + TODO => 'apply fix from ExtUtils-MakeMaker PR#135', +}, +{ + name => 'our $VERSION inside BEGIN block', + code => <<'---', + '1.23' => <<'---', # our + BEGIN +package Simple; + BEGIN { our $VERSION = '1.23' } +} +--- + vers => '1.23', + all_versions => { Simple => '1.23' }, + TODO => 'apply fix from ExtUtils-MakeMaker PR#135', +}, +{ + name => 'no assumption of primary version merely if a package\'s $VERSION is referenced', + code => <<'---', +package Simple; +$Foo::Bar::VERSION = '1.23'; +--- + vers => undef, + all_versions => { 'Foo::Bar' => '1.23' }, +}, +{ + name => 'no package statement; bare $VERSION', + code => <<'---', +$VERSION = '1.23'; +--- + vers => undef, + all_versions => { '____caller' => '1.23' }, + TODO => 'FIXME! RT#74741', +}, +{ + name => 'no package statement; bare $VERSION with our', + code => <<'---', +our $VERSION = '1.23'; +--- + vers => undef, + all_versions => { '____caller' => '1.23' }, + TODO => 'FIXME! RT#74741', +}, +{ + name => 'no package statement; fully-qualified $VERSION for main', + code => <<'---', +$::VERSION = '1.23'; +--- + vers => undef, + all_versions => { 'main' => '1.23' }, +}, +{ + name => 'no package statement; fully-qualified $VERSION for other package', + code => <<'---', +$Foo::Bar::VERSION = '1.23'; +--- + vers => undef, + all_versions => { 'Foo::Bar' => '1.23' }, +}, +); + +my $test_num = 0; + +my $tmpdir = GeneratePackage::tmpdir(); + +# iterate through @modules +foreach my $test_case (@modules) { + note '-------'; + note $test_case->{name}; + my $code = $test_case->{code}; + my $expected_version = $test_case->{vers}; + local $TODO = $test_case->{TODO}; + SKIP: { + skip( "No our() support until perl 5.6", (defined $expected_version ? 3 : 2) ) + if $] < 5.006 && $code =~ /\bour\b/; + skip( "No package NAME VERSION support until perl 5.11.1", (defined $expected_version ? 3 : 2) ) + if $] < 5.011001 && $code =~ /package\s+[\w\:\']+\s+v?[0-9._]+/; + + my $warnings = ''; + local $SIG{__WARN__} = sub { $warnings .= $_ for @_ }; + + my $pm_info = Module::Metadata->new_from_file(generate_file(File::Spec->catdir($tmpdir, "Simple${test_num}"), 'Simple.pm', $code)); + + # whenever we drop support for 5.6, we can do this: + # open my $fh, '<', \(encode('UTF-8', $code, Encode::FB_CROAK)) + # or die "cannot open handle to code string: $!"; + # my $pm_info = Module::Metadata->new_from_handle($fh, 'lib/Simple.pm'); + + my $errs; + my $got = $pm_info->version; + + # note that in Test::More 0.94 and earlier, is() stringifies first before comparing; + # from 0.95_01 and later, it just lets the objects figure out how to handle 'eq' + # We want to ensure we preserve the original, as long as it's legal, so we + # explicitly check the stringified form. + isa_ok($got, 'version') if defined $expected_version; + + if (ref($expected_version) eq 'CODE') { + ok( + $expected_version->($got), + "case '$test_case->{name}': module version passes match sub" + ) + or $errs++; + } + else { + is( + (defined $got ? "$got" : $got), + $expected_version, + "case '$test_case->{name}': correct module version (" + . (defined $expected_version? "'$expected_version'" : 'undef') + . ')' + ) + or $errs++; + } + + if (exists $test_case->{all_versions}) { + if (ref($expected_version) eq 'CODE') { + ok( + $test_case->{all_versions}->($pm_info->{versions}), + "case '$test_case->{name}': all extracted versions passes match sub" + ) or diag 'found versions: ', explain $pm_info->{versions}; + } + else { + is_deeply( + $pm_info->{versions}, + $test_case->{all_versions}, + 'correctly found all $VERSIONs', + ) or diag 'found versions: ', explain $pm_info->{versions}; + } + } + + is( $warnings, '', "case '$test_case->{name}': no warnings from parsing" ) or $errs++; + diag Dumper({ got => $pm_info->version, module_contents => $code }) if $errs; + } +} +continue { + ++$test_num; +} + +done_testing; diff --git a/cpan/Module-Metadata/t/lib/GeneratePackage.pm b/cpan/Module-Metadata/t/lib/GeneratePackage.pm new file mode 100644 index 0000000..07c92d3 --- /dev/null +++ b/cpan/Module-Metadata/t/lib/GeneratePackage.pm @@ -0,0 +1,38 @@ +use strict; +use warnings; +package GeneratePackage; +# vim:ts=8:sw=2:et:sta:sts=2 + +use base 'Exporter'; +our @EXPORT = qw(tmpdir generate_file); + +use Cwd; +use File::Spec; +use File::Path; +use File::Temp; +use IO::File; + +sub tmpdir { + File::Temp::tempdir( + 'MMD-XXXXXXXX', + CLEANUP => 1, + DIR => ($ENV{PERL_CORE} ? File::Spec->rel2abs(Cwd::cwd) : File::Spec->tmpdir), + ); +} + +sub generate_file { + my ($dir, $rel_filename, $content) = @_; + + File::Path::mkpath($dir) or die "failed to create '$dir'"; + my $abs_filename = File::Spec->catfile($dir, $rel_filename); + + Test::More::note("working on $abs_filename"); + + my $fh = IO::File->new(">$abs_filename") or die "Can't write '$abs_filename'\n"; + print $fh $content; + close $fh; + + return $abs_filename; +} + +1; diff --git a/cpan/Module-Metadata/t/metadata.t b/cpan/Module-Metadata/t/metadata.t index 67c68a9..068a865 100644 --- a/cpan/Module-Metadata/t/metadata.t +++ b/cpan/Module-Metadata/t/metadata.t @@ -12,281 +12,7 @@ use Cwd (); use File::Path; use Data::Dumper; -my $undef; - -# parse various module $VERSION lines -# format: expected version => code snippet -my @modules = ( - $undef => <<'---', # no $VERSION line -package Simple; ---- - $undef => <<'---', # undefined $VERSION -package Simple; -our $VERSION; ---- - '1.23' => <<'---', # declared & defined on same line with 'our' -package Simple; -our $VERSION = '1.23'; ---- - '1.23' => <<'---', # declared & defined on separate lines with 'our' -package Simple; -our $VERSION; -$VERSION = '1.23'; ---- - '1.23' => <<'---', # commented & defined on same line -package Simple; -our $VERSION = '1.23'; # our $VERSION = '4.56'; ---- - '1.23' => <<'---', # commented & defined on separate lines -package Simple; -# our $VERSION = '4.56'; -our $VERSION = '1.23'; ---- - '1.23' => <<'---', # use vars -package Simple; -use vars qw( $VERSION ); -$VERSION = '1.23'; ---- - '1.23' => <<'---', # choose the right default package based on package/file name -package Simple::_private; -$VERSION = '0'; -package Simple; -$VERSION = '1.23'; # this should be chosen for version ---- - '1.23' => <<'---', # just read the first $VERSION line -package Simple; -$VERSION = '1.23'; # we should see this line -$VERSION = eval $VERSION; # and ignore this one ---- - '1.23' => <<'---', # just read the first $VERSION line in reopened package (1) -package Simple; -$VERSION = '1.23'; -package Error::Simple; -$VERSION = '2.34'; -package Simple; ---- - '1.23' => <<'---', # just read the first $VERSION line in reopened package (2) -package Simple; -package Error::Simple; -$VERSION = '2.34'; -package Simple; -$VERSION = '1.23'; ---- - '1.23' => <<'---', # mentions another module's $VERSION -package Simple; -$VERSION = '1.23'; -if ( $Other::VERSION ) { - # whatever -} ---- - '1.23' => <<'---', # mentions another module's $VERSION in a different package -package Simple; -$VERSION = '1.23'; -package Simple2; -if ( $Simple::VERSION ) { - # whatever -} ---- - '1.23' => <<'---', # $VERSION checked only in assignments, not regexp ops -package Simple; -$VERSION = '1.23'; -if ( $VERSION =~ /1\.23/ ) { - # whatever -} ---- - '1.23' => <<'---', # $VERSION checked only in assignments, not relational ops -package Simple; -$VERSION = '1.23'; -if ( $VERSION == 3.45 ) { - # whatever -} ---- - '1.23' => <<'---', # $VERSION checked only in assignments, not relational ops -package Simple; -$VERSION = '1.23'; -package Simple2; -if ( $Simple::VERSION == 3.45 ) { - # whatever -} ---- - '1.23' => <<'---', # Fully qualified $VERSION declared in package -package Simple; -$Simple::VERSION = 1.23; ---- - '1.23' => <<'---', # Differentiate fully qualified $VERSION in a package -package Simple; -$Simple2::VERSION = '999'; -$Simple::VERSION = 1.23; ---- - '1.23' => <<'---', # Differentiate fully qualified $VERSION and unqualified -package Simple; -$Simple2::VERSION = '999'; -$VERSION = 1.23; ---- - '1.23' => <<'---', # $VERSION declared as package variable from within 'main' package -$Simple::VERSION = '1.23'; -{ - package Simple; - $x = $y, $cats = $dogs; -} ---- - '1.23' => <<'---', # $VERSION wrapped in parens - space inside -package Simple; -( $VERSION ) = '1.23'; ---- - '1.23' => <<'---', # $VERSION wrapped in parens - no space inside -package Simple; -($VERSION) = '1.23'; ---- - '1.23' => <<'---', # $VERSION follows a spurious 'package' in a quoted construct -package Simple; -__PACKAGE__->mk_accessors(qw( - program socket proc - package filename line codeline subroutine finished)); - -our $VERSION = "1.23"; ---- - '1.23' => <<'---', # $VERSION using version.pm - package Simple; - use version; our $VERSION = version->new('1.23'); ---- - 'v1.230' => <<'---', # $VERSION using version.pm and qv() - package Simple; - use version; our $VERSION = qv('1.230'); ---- - '1.230' => <<'---', # Two version assignments, should ignore second one - $Simple::VERSION = '1.230'; - $Simple::VERSION = eval $Simple::VERSION; ---- - '1.230000' => <<'---', # declared & defined on same line with 'our' -package Simple; -our $VERSION = '1.23_00_00'; ---- - '1.23' => <<'---', # package NAME VERSION - package Simple 1.23; ---- - '1.23_01' => <<'---', # package NAME VERSION - package Simple 1.23_01; ---- - 'v1.2.3' => <<'---', # package NAME VERSION - package Simple v1.2.3; ---- - 'v1.2_3' => <<'---', # package NAME VERSION - package Simple v1.2_3; ---- - '1.23' => <<'---', # trailing crud - package Simple; - our $VERSION; - $VERSION = '1.23-alpha'; ---- - '1.23' => <<'---', # trailing crud - package Simple; - our $VERSION; - $VERSION = '1.23b'; ---- - '1.234' => <<'---', # multi_underscore - package Simple; - our $VERSION; - $VERSION = '1.2_3_4'; ---- - '0' => <<'---', # non-numeric - package Simple; - our $VERSION; - $VERSION = 'onetwothree'; ---- - $undef => <<'---', # package NAME BLOCK, undef $VERSION -package Simple { - our $VERSION; -} ---- - '1.23' => <<'---', # package NAME BLOCK, with $VERSION -package Simple { - our $VERSION = '1.23'; -} ---- - '1.23' => <<'---', # package NAME VERSION BLOCK -package Simple 1.23 { - 1; -} ---- - 'v1.2.3_4' => <<'---', # package NAME VERSION BLOCK -package Simple v1.2.3_4 { - 1; -} ---- - '0' => <<'---', # set from separately-initialised variable -package Simple; - our $CVSVERSION = '$Revision: 1.7 $'; - our ($VERSION) = ($CVSVERSION =~ /(\d+\.\d+)/); -} ---- - 'v2.2.102.2' => <<'---', # our + bare v-string -package Simple; -our $VERSION = v2.2.102.2; ---- - '0.0.9_1' => <<'---', # our + dev release -package Simple; -our $VERSION = "0.0.9_1"; ---- - '1.12' => <<'---', # our + crazy string and substitution code -package Simple; -our $VERSION = '1.12.B55J2qn'; our $WTF = $VERSION; $WTF =~ s/^\d+\.\d+\.//; # attempts to rationalize $WTF go here. ---- - '1.12' => <<'---', # our in braces, as in Dist::Zilla::Plugin::PkgVersion with use_our = 1 -package Simple; -{ our $VERSION = '1.12'; } ---- - sub { defined $_[0] and $_[0] =~ /^3\.14159/ } => <<'---', # calculated version - from Acme-Pi-3.14 -package Simple; -my $version = atan2(1,1) * 4; $Simple::VERSION = "$version"; -1; ---- -); - -# format: expected package name => code snippet -my @pkg_names = ( - [ 'Simple' ] => <<'---', # package NAME -package Simple; ---- - [ 'Simple::Edward' ] => <<'---', # package NAME::SUBNAME -package Simple::Edward; ---- - [ 'Simple::Edward::' ] => <<'---', # package NAME::SUBNAME:: -package Simple::Edward::; ---- - [ "Simple'Edward" ] => <<'---', # package NAME'SUBNAME -package Simple'Edward; ---- - [ "Simple'Edward::" ] => <<'---', # package NAME'SUBNAME:: -package Simple'Edward::; ---- - [ 'Simple::::Edward' ] => <<'---', # package NAME::::SUBNAME -package Simple::::Edward; ---- - [ '::Simple::Edward' ] => <<'---', # package ::NAME::SUBNAME -package ::Simple::Edward; ---- - [ 'main' ] => <<'---', # package NAME:SUBNAME (fail) -package Simple:Edward; ---- - [ 'main' ] => <<'---', # package NAME' (fail) -package Simple'; ---- - [ 'main' ] => <<'---', # package NAME::SUBNAME' (fail) -package Simple::Edward'; ---- - [ 'main' ] => <<'---', # package NAME''SUBNAME (fail) -package Simple''Edward; ---- - [ 'main' ] => <<'---', # package NAME-SUBNAME (fail) -package Simple-Edward; ---- -); - -# 2 tests per each pair of @modules (plus 1 for defined keys), 2 per pair of @pkg_names -plan tests => 63 - + ( @modules + grep { defined $modules[2*$_] } 0..$#modules/2 ) - + ( @pkg_names ); +plan tests => 61; require_ok('Module::Metadata'); @@ -395,73 +121,6 @@ END { } -# iterate through @modules pairwise -my $test_case = 0; -while (++$test_case and my ($expected_version, $code) = splice @modules, 0, 2 ) { - SKIP: { - skip( "No our() support until perl 5.6", (defined $expected_version ? 3 : 2) ) - if $] < 5.006 && $code =~ /\bour\b/; - skip( "No package NAME VERSION support until perl 5.11.1", (defined $expected_version ? 3 : 2) ) - if $] < 5.011001 && $code =~ /package\s+[\w\:\']+\s+v?[0-9._]+/; - - my $file = File::Spec->catfile('lib', 'Simple.pm'); - my ($dist_name, $dist_dir) = new_dist(files => { $file => $code }); - - my $warnings = ''; - local $SIG{__WARN__} = sub { $warnings .= $_ for @_ }; - my $pm_info = Module::Metadata->new_from_file( $file ); - - my $errs; - my $got = $pm_info->version; - - # note that in Test::More 0.94 and earlier, is() stringifies first before comparing; - # from 0.95_01 and later, it just lets the objects figure out how to handle 'eq' - # We want to ensure we preserve the original, as long as it's legal, so we - # explicitly check the stringified form. - isa_ok($got, 'version') if defined $expected_version; - - if (ref($expected_version) eq 'CODE') { - ok( - $expected_version->($got), - "case $test_case: module version passes match sub" - ) - or $errs++; - } - else { - is( - (defined $got ? "$got" : $got), - $expected_version, - "case $test_case: correct module version (" - . (defined $expected_version? "'$expected_version'" : 'undef') - . ')' - ) - or $errs++; - } - - is( $warnings, '', "case $test_case: no warnings from parsing" ) or $errs++; - diag Dumper({ got => $pm_info->version, module_contents => $code }) if $errs; - } -} - -$test_case = 0; -while (++$test_case and my ($expected_name, $code) = splice @pkg_names, 0, 2) { - my $file = File::Spec->catfile('lib', 'Simple.pm'); - my ($dist_name, $dist_dir) = new_dist(files => { $file => $code }); - - my $warnings = ''; - local $SIG{__WARN__} = sub { $warnings .= $_ for @_ }; - my $pm_info = Module::Metadata->new_from_file( $file ); - - # Test::Builder will prematurely numify objects, so use this form - my $errs; - my @got = $pm_info->packages_inside(); - is_deeply( \@got, $expected_name, - "case $test_case: correct package names (expected '" . join(', ', @$expected_name) . "')" ) - or $errs++; - is( $warnings, '', "case $test_case: no warnings from parsing" ) or $errs++; - diag "Got: '" . join(', ', @got) . "'\nModule contents:\n$code" if $errs; -} - { # Find each package only once my $file = File::Spec->catfile('lib', 'Simple.pm'); @@ -494,29 +153,6 @@ $VERSION = '1.23'; is( $pm_info->version, undef, 'no version w/o default package' ); } -{ - # Module 'Simple.pm' contains an alpha version - # constructor should report first $VERSION found - my $file = File::Spec->catfile('lib', 'Simple.pm'); - my ($dist_name, $dist_dir) = new_dist(files => { $file => <<'---' } ); -package Simple; -$VERSION = '1.23_01'; -$VERSION = eval $VERSION; ---- - - my $pm_info = Module::Metadata->new_from_file( $file ); - - is( $pm_info->version, '1.23_01', 'alpha version reported'); - - # NOTE the following test has be done this way because Test::Builder is - # too smart for our own good and tries to see if the version object is a - # dual-var, which breaks with alpha versions: - # Argument "1.23_0100" isn't numeric in addition (+) at - # /usr/lib/perl5/5.8.7/Test/Builder.pm line 505. - - ok( $pm_info->version > 1.23, 'alpha version greater than non'); -} - # parse $VERSION lines scripts for package main my @scripts = ( <<'---', # package main declared diff --git a/cpan/Perl-OSType/lib/Perl/OSType.pm b/cpan/Perl-OSType/lib/Perl/OSType.pm index 0d5b54b..8a91577 100644 --- a/cpan/Perl-OSType/lib/Perl/OSType.pm +++ b/cpan/Perl-OSType/lib/Perl/OSType.pm @@ -4,7 +4,7 @@ use warnings; package Perl::OSType; # ABSTRACT: Map Perl operating system names to generic types -our $VERSION = '1.008'; +our $VERSION = '1.009'; require Exporter; our @ISA = qw(Exporter); @@ -40,6 +40,7 @@ my %OSTYPES = qw( nto Unix svr4 Unix svr5 Unix + sco Unix sco_sv Unix unicos Unix unicosmk Unix @@ -95,7 +96,7 @@ Perl::OSType - Map Perl operating system names to generic types =head1 VERSION -version 1.008 +version 1.009 =head1 SYNOPSIS @@ -156,7 +157,7 @@ L =head2 Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker -at L. +at L. You will be notified automatically of any progress on your issue. =head2 Source Code @@ -164,9 +165,9 @@ You will be notified automatically of any progress on your issue. This is open source software. The code repository is available for public review and contribution under the terms of the license. -L +L - git clone https://github.com/dagolden/Perl-OSType.git + git clone https://github.com/Perl-Toolchain-Gang/Perl-OSType.git =head1 AUTHOR diff --git a/cpan/Socket/Socket.pm b/cpan/Socket/Socket.pm index cd572af..dd89450 100644 --- a/cpan/Socket/Socket.pm +++ b/cpan/Socket/Socket.pm @@ -3,7 +3,7 @@ package Socket; use strict; { use 5.006001; } -our $VERSION = '2.020_01'; # patched in perl5.git +our $VERSION = '2.020_02'; # patched in perl5.git =head1 NAME diff --git a/cpan/Socket/Socket.xs b/cpan/Socket/Socket.xs index 5f60afa..52df483 100644 --- a/cpan/Socket/Socket.xs +++ b/cpan/Socket/Socket.xs @@ -52,18 +52,40 @@ #endif #ifdef WIN32 -int inet_pton(int af, const char *src, void *dst) + +/* VC 6 with its original headers doesn't know about sockaddr_storage, VC 2003 does*/ +#ifndef _SS_MAXSIZE + +# define _SS_MAXSIZE 128 +# define _SS_ALIGNSIZE (sizeof(__int64)) + +# define _SS_PAD1SIZE (_SS_ALIGNSIZE - sizeof (short)) +# define _SS_PAD2SIZE (_SS_MAXSIZE - (sizeof (short) + _SS_PAD1SIZE \ + + _SS_ALIGNSIZE)) + +struct sockaddr_storage { + short ss_family; + char __ss_pad1[_SS_PAD1SIZE]; + __int64 __ss_align; + char __ss_pad2[_SS_PAD2SIZE]; +}; + +typedef int socklen_t; + +#define in6_addr in_addr6 + +#define INET_ADDRSTRLEN 22 +#define INET6_ADDRSTRLEN 65 + +#endif + +static int inet_pton(int af, const char *src, void *dst) { struct sockaddr_storage ss; int size = sizeof(ss); - char src_copy[INET6_ADDRSTRLEN+1]; + ss.ss_family = af; /* per MSDN */ - ZeroMemory(&ss, sizeof(ss)); - /* stupid non-const API */ - strncpy(src_copy, src, INET6_ADDRSTRLEN+1); - src_copy[INET6_ADDRSTRLEN] = 0; - - if (WSAStringToAddress(src_copy, af, NULL, (struct sockaddr *)&ss, &size) != 0) + if (WSAStringToAddress((char*)src, af, NULL, (struct sockaddr *)&ss, &size) != 0) return 0; switch(af) { @@ -73,10 +95,13 @@ int inet_pton(int af, const char *src, void *dst) case AF_INET6: *(struct in6_addr *)dst = ((struct sockaddr_in6 *)&ss)->sin6_addr; return 1; + default: + WSASetLastError(WSAEAFNOSUPPORT); + return -1; } } -const char *inet_ntop(int af, const void *src, char *dst, socklen_t size) +static const char *inet_ntop(int af, const void *src, char *dst, socklen_t size) { struct sockaddr_storage ss; unsigned long s = size; diff --git a/cpan/Unicode-Normalize/Normalize.pm b/cpan/Unicode-Normalize/Normalize.pm index 27514f2..b828543 100644 --- a/cpan/Unicode-Normalize/Normalize.pm +++ b/cpan/Unicode-Normalize/Normalize.pm @@ -16,7 +16,7 @@ use Carp; no warnings 'utf8'; -our $VERSION = '1.19'; +our $VERSION = '1.21'; our $PACKAGE = __PACKAGE__; our @EXPORT = qw( NFC NFD NFKC NFKD ); @@ -45,9 +45,29 @@ sub pack_U { } sub unpack_U { + + # The empty pack returns an empty UTF-8 string, so the effect is to force + # the shifted parameter into being UTF-8. This shouldn't matter; the + # commit messages seem to point to an attempt to get things to work in + # EBCDIC in 5.8. return unpack('U*', shift(@_).pack('U*')); } +BEGIN { + # Starting in v5.20, the tables in lib/unicore are built using the + # platform's native character set for code points 0-255. Things like the + # combining class and compositions exclusions are all above 255, so it + # doesn't matter for them. + + *pack_unicore = ($] ge 5.020) + ? sub { return pack('W*', @_); } + : \&pack_U; + + *unpack_unicore = ($] ge 5.020) + ? sub { return unpack('W*', $_[0]); } + : \&unpack_U; +} + require Exporter; our @ISA = qw(Exporter); @@ -70,7 +90,9 @@ our $Decomp = do "unicore/Decomposition.pl" || do "unicode/Decomposition.pl" || croak "$PACKAGE: Decomposition.pl not found"; -# CompositionExclusions.txt since Unicode 3.2.0 +# CompositionExclusions.txt since Unicode 3.2.0. Modern perl versions allow +# one to get this table from Unicode::UCD, so if it ever changes, it might be +# better to retrieve it from there, rather than hard-coding it here. our @CompEx = qw( 0958 0959 095A 095B 095C 095D 095E 095F 09DC 09DD 09DF 0A33 0A36 0A59 0A5A 0A5B 0A5E 0B5C 0B5D 0F43 0F4D 0F52 0F57 0F5C 0F69 0F76 @@ -106,7 +128,7 @@ sub decomposeHangul { VBase + $vindex, $tindex ? (TBase + $tindex) : (), ); - return wantarray ? @ret : pack_U(@ret); + return wantarray ? @ret : pack_unicore(@ret); } ########## getting full decomposition ########## @@ -223,7 +245,7 @@ sub getCombinClass ($) { sub getCanon ($) { my $uv = 0 + shift; return exists $Canon{$uv} - ? pack_U(@{ $Canon{$uv} }) + ? pack_unicore(@{ $Canon{$uv} }) : (SBase <= $uv && $uv <= SFinal) ? scalar decomposeHangul($uv) : undef; @@ -232,7 +254,7 @@ sub getCanon ($) { sub getCompat ($) { my $uv = 0 + shift; return exists $Compat{$uv} - ? pack_U(@{ $Compat{$uv} }) + ? pack_unicore(@{ $Compat{$uv} }) : (SBase <= $uv && $uv <= SFinal) ? scalar decomposeHangul($uv) : undef; @@ -310,10 +332,10 @@ sub isNFKC_NO ($) { sub decompose ($;$) { my $hash = $_[1] ? \%Compat : \%Canon; - return pack_U map { + return pack_unicore map { $hash->{ $_ } ? @{ $hash->{ $_ } } : (SBase <= $_ && $_ <= SFinal) ? decomposeHangul($_) : $_ - } unpack_U($_[0]); + } unpack_unicore($_[0]); } ## @@ -321,7 +343,7 @@ sub decompose ($;$) ## sub reorder ($) { - my @src = unpack_U($_[0]); + my @src = unpack_unicore($_[0]); for (my $i=0; $i < @src;) { $i++, next if ! $Combin{ $src[$i] }; @@ -335,7 +357,7 @@ sub reorder ($) @src[ $ini .. $i - 1 ] = @src[ @tmp ]; } - return pack_U(@src); + return pack_unicore(@src); } @@ -350,7 +372,7 @@ sub reorder ($) ## sub compose ($) { - my @src = unpack_U($_[0]); + my @src = unpack_unicore($_[0]); for (my $s = 0; $s+1 < @src; $s++) { next unless defined $src[$s] && ! $Combin{ $src[$s] }; @@ -377,7 +399,7 @@ sub compose ($) if ($blocked) { $blocked = 0 } else { -- $uncomposed_cc } } } - return pack_U(grep defined, @src); + return pack_unicore(grep defined, @src); } @@ -386,7 +408,7 @@ sub compose ($) ## sub composeContiguous ($) { - my @src = unpack_U($_[0]); + my @src = unpack_unicore($_[0]); for (my $s = 0; $s+1 < @src; $s++) { next unless defined $src[$s] && ! $Combin{ $src[$s] }; @@ -402,7 +424,7 @@ sub composeContiguous ($) $src[$s] = $c; $src[$j] = undef; } } - return pack_U(grep defined, @src); + return pack_unicore(grep defined, @src); } @@ -426,7 +448,7 @@ sub checkNFD ($) { my $preCC = 0; my $curCC; - for my $uv (unpack_U($_[0])) { + for my $uv (unpack_unicore($_[0])) { $curCC = $Combin{ $uv } || 0; return '' if $preCC > $curCC && $curCC != 0; return '' if exists $Canon{$uv} || (SBase <= $uv && $uv <= SFinal); @@ -439,7 +461,7 @@ sub checkNFKD ($) { my $preCC = 0; my $curCC; - for my $uv (unpack_U($_[0])) { + for my $uv (unpack_unicore($_[0])) { $curCC = $Combin{ $uv } || 0; return '' if $preCC > $curCC && $curCC != 0; return '' if exists $Compat{$uv} || (SBase <= $uv && $uv <= SFinal); @@ -452,7 +474,7 @@ sub checkNFC ($) { my $preCC = 0; my($curCC, $isMAYBE); - for my $uv (unpack_U($_[0])) { + for my $uv (unpack_unicore($_[0])) { $curCC = $Combin{ $uv } || 0; return '' if $preCC > $curCC && $curCC != 0; @@ -470,7 +492,7 @@ sub checkNFKC ($) { my $preCC = 0; my($curCC, $isMAYBE); - for my $uv (unpack_U($_[0])) { + for my $uv (unpack_unicore($_[0])) { $curCC = $Combin{ $uv } || 0; return '' if $preCC > $curCC && $curCC != 0; @@ -488,7 +510,7 @@ sub checkFCD ($) { my $preCC = 0; my $curCC; - for my $uv (unpack_U($_[0])) { + for my $uv (unpack_unicore($_[0])) { # Hangul syllable need not decomposed since cc[any Jamo] == 0; my @uvCan = exists $Canon{$uv} ? @{ $Canon{$uv} } : ($uv); @@ -503,7 +525,7 @@ sub checkFCC ($) { my $preCC = 0; my($curCC, $isMAYBE); - for my $uv (unpack_U($_[0])) { + for my $uv (unpack_unicore($_[0])) { # Hangul syllable need not decomposed since cc[any Jamo] == 0; my @uvCan = exists $Canon{$uv} ? @{ $Canon{$uv} } : ($uv); @@ -527,7 +549,7 @@ sub checkFCC ($) sub splitOnLastStarter { - my $str = pack_U(unpack_U(shift)); + my $str = pack_unicore(unpack_unicore(shift)); if ($str eq '') { return ('', ''); } @@ -537,7 +559,9 @@ sub splitOnLastStarter do { $ch = chop($str); $unproc = $ch.$unproc; - } while (getCombinClass(unpack 'U', $ch) && $str ne ""); + } # Relies on the fact that the combining class for code points < 256 is + # 0, so don't have to worry about EBCDIC issues + while (getCombinClass(unpack 'U', $ch) && $str ne ""); return ($str, $unproc); } @@ -1019,22 +1043,29 @@ C and other some functions: on request. Since this module refers to perl core's Unicode database in the directory F (or formerly F), the Unicode version of -normalization implemented by this module depends on your perl's version. +normalization implemented by this module depends on what has been +compiled into your perl. The following table lists the default Unicode +version that comes with various perl versions. (It is possible to change +the Unicode version in any perl version to be any earlier Unicode version, +so one could cause Unicode 3.2 to be used in any perl version starting with +5.8.0. See C<$Config{privlib}>/F. perl's version implemented Unicode version 5.6.1 3.0.1 5.7.2 3.1.0 5.7.3 3.1.1 (normalization is same as 3.1.0) 5.8.0 3.2.0 - 5.8.1-5.8.3 4.0.0 - 5.8.4-5.8.6 4.0.1 (normalization is same as 4.0.0) - 5.8.7-5.8.8 4.1.0 + 5.8.1-5.8.3 4.0.0 + 5.8.4-5.8.6 4.0.1 (normalization is same as 4.0.0) + 5.8.7-5.8.8 4.1.0 5.10.0 5.0.0 - 5.8.9, 5.10.1 5.1.0 + 5.8.9, 5.10.1 5.1.0 5.12.x 5.2.0 5.14.x 6.0.0 5.16.x 6.1.0 5.18.x 6.2.0 + 5.20.x 6.3.0 + 5.22.x 7.0.0 =item Correction of decomposition mapping diff --git a/cpan/Unicode-Normalize/t/func.t b/cpan/Unicode-Normalize/t/func.t index b92ada7..7295b47 100644 --- a/cpan/Unicode-Normalize/t/func.t +++ b/cpan/Unicode-Normalize/t/func.t @@ -39,19 +39,25 @@ ok(1); sub _pack_U { Unicode::Normalize::pack_U(@_) } sub hexU { _pack_U map hex, split ' ', shift } +# This won't work on EBCDIC platforms prior to v5.8.0, which is when this +# translation function was defined +*to_native = (defined &utf8::unicode_to_native) + ? \&utf8::unicode_to_native + : sub { return shift }; + ######################### -ok(getCombinClass( 0), 0); -ok(getCombinClass( 41), 0); -ok(getCombinClass( 65), 0); +ok(getCombinClass( to_native(0)), 0); +ok(getCombinClass(to_native(41)), 0); +ok(getCombinClass(to_native(65)), 0); ok(getCombinClass( 768), 230); ok(getCombinClass(1809), 36); -ok(getCanon( 0), undef); -ok(getCanon(0x29), undef); -ok(getCanon(0x41), undef); -ok(getCanon(0x00C0), _pack_U(0x0041, 0x0300)); -ok(getCanon(0x00EF), _pack_U(0x0069, 0x0308)); +ok(getCanon(to_native( 0)), undef); +ok(getCanon(to_native(0x29)), undef); +ok(getCanon(to_native(0x41)), undef); +ok(getCanon(to_native(0x00C0)), _pack_U(0x0041, 0x0300)); +ok(getCanon(to_native(0x00EF)), _pack_U(0x0069, 0x0308)); ok(getCanon(0x304C), _pack_U(0x304B, 0x3099)); ok(getCanon(0x1EA4), _pack_U(0x0041, 0x0302, 0x0301)); ok(getCanon(0x1F82), _pack_U(0x03B1, 0x0313, 0x0300, 0x0345)); @@ -64,11 +70,11 @@ ok(getCanon(0xFA2D), _pack_U(0x9DB4)); # 20 -ok(getCompat( 0), undef); -ok(getCompat(0x29), undef); -ok(getCompat(0x41), undef); -ok(getCompat(0x00C0), _pack_U(0x0041, 0x0300)); -ok(getCompat(0x00EF), _pack_U(0x0069, 0x0308)); +ok(getCompat(to_native( 0)), undef); +ok(getCompat(to_native(0x29)), undef); +ok(getCompat(to_native(0x41)), undef); +ok(getCompat(to_native(0x00C0)), _pack_U(0x0041, 0x0300)); +ok(getCompat(to_native(0x00EF)), _pack_U(0x0069, 0x0308)); ok(getCompat(0x304C), _pack_U(0x304B, 0x3099)); ok(getCompat(0x1EA4), _pack_U(0x0041, 0x0302, 0x0301)); ok(getCompat(0x1F82), _pack_U(0x03B1, 0x0313, 0x0300, 0x0345)); @@ -81,17 +87,17 @@ ok(getCompat(0xFA2D), _pack_U(0x9DB4)); # 34 -ok(getComposite( 0, 0), undef); -ok(getComposite( 0, 0x29), undef); -ok(getComposite(0x29, 0), undef); -ok(getComposite(0x29, 0x29), undef); -ok(getComposite( 0, 0x41), undef); -ok(getComposite(0x41, 0), undef); -ok(getComposite(0x41, 0x41), undef); -ok(getComposite(12, 0x0300), undef); -ok(getComposite(0x0055, 0xFF00), undef); -ok(getComposite(0x0041, 0x0300), 0x00C0); -ok(getComposite(0x0055, 0x0300), 0x00D9); +ok(getComposite(to_native( 0), to_native( 0)), undef); +ok(getComposite(to_native( 0), to_native(0x29)), undef); +ok(getComposite(to_native(0x29), to_native( 0)), undef); +ok(getComposite(to_native(0x29), to_native(0x29)), undef); +ok(getComposite(to_native( 0), to_native(0x41)), undef); +ok(getComposite(to_native(0x41), to_native( 0)), undef); +ok(getComposite(to_native(0x41), to_native(0x41)), undef); +ok(getComposite(to_native(12), to_native(0x0300)), undef); +ok(getComposite(to_native(0x0055), 0xFF00), undef); +ok(getComposite(to_native(0x0041), 0x0300), to_native(0x00C0)); +ok(getComposite(to_native(0x0055), 0x0300), to_native(0x00D9)); ok(getComposite(0x0112, 0x0300), 0x1E14); ok(getComposite(0x1100, 0x1161), 0xAC00); ok(getComposite(0x1100, 0x1173), 0xADF8); @@ -120,11 +126,11 @@ sub uprops { return $r; } -ok(uprops(0x0000), 'xsnfbdmckyg'); # NULL -ok(uprops(0x0029), 'xsnfbdmckyg'); # RIGHT PARENTHESIS -ok(uprops(0x0041), 'xsnfbdmckyg'); # LATIN CAPITAL LETTER A -ok(uprops(0x00A0), 'xsnfbdmcKyG'); # NO-BREAK SPACE -ok(uprops(0x00C0), 'xsnfbDmcKyg'); # LATIN CAPITAL LETTER A WITH GRAVE +ok(uprops(to_native(0x0000)), 'xsnfbdmckyg'); # NULL +ok(uprops(to_native(0x0029)), 'xsnfbdmckyg'); # RIGHT PARENTHESIS +ok(uprops(to_native(0x0041)), 'xsnfbdmckyg'); # LATIN CAPITAL LETTER A +ok(uprops(to_native(0x00A0)), 'xsnfbdmcKyG'); # NO-BREAK SPACE +ok(uprops(to_native(0x00C0)), 'xsnfbDmcKyg'); # LATIN CAPITAL LETTER A WITH GRAVE ok(uprops(0x0300), 'xsnfBdMckYg'); # COMBINING GRAVE ACCENT ok(uprops(0x0344), 'xsNFbDmCKyG'); # COMBINING GREEK DIALYTIKA TONOS ok(uprops(0x0387), 'xSnFbDmCKyG'); # GREEK ANO TELEIA @@ -266,12 +272,13 @@ ok(normalize('NFC', $2), "ABC"); # a string with initial zero should be treated like a number # LATIN CAPITAL LETTER A WITH GRAVE -ok(getCombinClass("0192"), 0); -ok(getCanon ("0192"), _pack_U(0x41, 0x300)); -ok(getCompat("0192"), _pack_U(0x41, 0x300)); -ok(getComposite("065", "0768"), 192); -ok(isNFD_NO ("0192")); -ok(isNFKD_NO("0192")); +ok(getCombinClass(sprintf("0%d", to_native(192))), 0); +ok(getCanon (sprintf("0%d", to_native(192))), _pack_U(0x41, 0x300)); +ok(getCompat(sprintf("0%d", to_native(192))), _pack_U(0x41, 0x300)); +my $lead_zero = sprintf "0%d", to_native(65); +ok(getComposite($lead_zero, "0768"), to_native(192)); +ok(isNFD_NO (sprintf("0%d", to_native(192)))); +ok(isNFKD_NO(sprintf("0%d", to_native(192)))); # DEVANAGARI LETTER QA ok(isExclusion("02392")); diff --git a/dist/bignum/lib/Math/BigFloat/Trace.pm b/cpan/bignum/lib/Math/BigFloat/Trace.pm similarity index 98% rename from dist/bignum/lib/Math/BigFloat/Trace.pm rename to cpan/bignum/lib/Math/BigFloat/Trace.pm index 6eee9fa..a034615 100644 --- a/dist/bignum/lib/Math/BigFloat/Trace.pm +++ b/cpan/bignum/lib/Math/BigFloat/Trace.pm @@ -12,7 +12,7 @@ use vars qw($VERSION @ISA $PACKAGE @EXPORT_OK @ISA = qw(Exporter Math::BigFloat); -$VERSION = '0.40'; +$VERSION = '0.41'; use overload; # inherit overload from BigFloat diff --git a/dist/bignum/lib/Math/BigInt/Trace.pm b/cpan/bignum/lib/Math/BigInt/Trace.pm similarity index 98% rename from dist/bignum/lib/Math/BigInt/Trace.pm rename to cpan/bignum/lib/Math/BigInt/Trace.pm index 6cab46c..b43f36e 100644 --- a/dist/bignum/lib/Math/BigInt/Trace.pm +++ b/cpan/bignum/lib/Math/BigInt/Trace.pm @@ -12,7 +12,7 @@ use vars qw($VERSION @ISA $PACKAGE @EXPORT_OK @ISA = qw(Exporter Math::BigInt); -$VERSION = '0.40'; +$VERSION = '0.41'; use overload; # inherit overload from BigInt diff --git a/dist/bignum/lib/bigint.pm b/cpan/bignum/lib/bigint.pm similarity index 89% rename from dist/bignum/lib/bigint.pm rename to cpan/bignum/lib/bigint.pm index e6481bd..71009a4 100644 --- a/dist/bignum/lib/bigint.pm +++ b/cpan/bignum/lib/bigint.pm @@ -1,7 +1,7 @@ package bigint; use 5.006; -$VERSION = '0.40'; +$VERSION = '0.41'; use Exporter; @ISA = qw( Exporter ); @EXPORT_OK = qw( PI e bpi bexp hex oct ); @@ -110,21 +110,109 @@ sub in_effect { use constant LEXICAL => $] > 5.009004; +# Internal function with the same semantics as CORE::hex(). This function is +# not used directly, but rather by other front-end functions. + +sub _hex_core { + my $str = shift; + + # Strip off, clean, and parse as much as we can from the beginning. + + my $x; + if ($str =~ s/ ^ (0?[xX])? ( [0-9a-fA-F]* ( _ [0-9a-fA-F]+ )* ) //x) { + my $chrs = $2; + $chrs =~ tr/_//d; + $chrs = '0' unless CORE::length $chrs; + $x = Math::BigInt -> from_hex($chrs); + } else { + $x = Math::BigInt -> bzero(); + } + + # Warn about trailing garbage. + + if (CORE::length($str)) { + require Carp; + Carp::carp(sprintf("Illegal hexadecimal digit '%s' ignored", + substr($str, 0, 1))); + } + + return $x; +} + +# Internal function with the same semantics as CORE::oct(). This function is +# not used directly, but rather by other front-end functions. + +sub _oct_core { + my $str = shift; + + $str =~ s/^\s*//; + + # Hexadecimal input. + + return _hex_core($str) if $str =~ /^0?[xX]/; + + my $x; + + # Binary input. + + if ($str =~ /^0?[bB]/) { + + # Strip off, clean, and parse as much as we can from the beginning. + + if ($str =~ s/ ^ (0?[bB])? ( [01]* ( _ [01]+ )* ) //x) { + my $chrs = $2; + $chrs =~ tr/_//d; + $chrs = '0' unless CORE::length $chrs; + $x = Math::BigInt -> from_bin($chrs); + } + + # Warn about trailing garbage. + + if (CORE::length($str)) { + require Carp; + Carp::carp(sprintf("Illegal binary digit '%s' ignored", + substr($str, 0, 1))); + } + + return $x; + } + + # Octal input. Strip off, clean, and parse as much as we can from the + # beginning. + + if ($str =~ s/ ^ ( [0-7]* ( _ [0-7]+ )* ) //x) { + my $chrs = $1; + $chrs =~ tr/_//d; + $chrs = '0' unless CORE::length $chrs; + $x = Math::BigInt -> from_oct($chrs); + } + + # Warn about trailing garbage. CORE::oct() only warns about 8 and 9. + + if (CORE::length($str)) { + my $chr = substr($str, 0, 1); + if ($chr eq '8' || $chr eq '9') { + require Carp; + Carp::carp(sprintf("Illegal octal digit '%s' ignored", $chr)); + } + } + + return $x; +} + { my $proto = LEXICAL ? '_' : ';$'; eval ' sub hex(' . $proto . ') {' . <<'.'; - my $i = @_ ? $_[0] : $_; - $i = '0x'.$i unless $i =~ /^0x/; - Math::BigInt->new($i); + my $str = @_ ? $_[0] : $_; + _hex_core($str); } . + eval ' sub oct(' . $proto . ') {' . <<'.'; - my $i = @_ ? $_[0] : $_; - # oct() should never fall back to decimal - return Math::BigInt->from_oct($i) if $i =~ s/^(?=0[0-9]|[1-9])/0/; - Math::BigInt->new($i); + my $str = @_ ? $_[0] : $_; + _oct_core($str); } . } @@ -139,19 +227,14 @@ sub _hex(_) { my $hh = (caller 0)[10]; return $prev_hex ? &$prev_hex($_[0]) : CORE::hex($_[0]) unless $$hh{bigint}||$$hh{bignum}||$$hh{bigrat}; - my $i = $_[0]; - $i = '0x'.$i unless $i =~ /^0x/; - Math::BigInt->new($i); + _hex_core($_[0]); } sub _oct(_) { my $hh = (caller 0)[10]; return $prev_oct ? &$prev_oct($_[0]) : CORE::oct($_[0]) unless $$hh{bigint}||$$hh{bignum}||$$hh{bigrat}; - my $i = $_[0]; - # oct() should never fall back to decimal - return Math::BigInt->from_oct($i) if $i =~ s/^(?=0[0-9]|[1-9])/0/; - Math::BigInt->new($i); + _oct_core($_[0]); } . diff --git a/dist/bignum/lib/bignum.pm b/cpan/bignum/lib/bignum.pm similarity index 99% rename from dist/bignum/lib/bignum.pm rename to cpan/bignum/lib/bignum.pm index 61f2bca..9387ff0 100644 --- a/dist/bignum/lib/bignum.pm +++ b/cpan/bignum/lib/bignum.pm @@ -1,7 +1,7 @@ package bignum; use 5.006; -$VERSION = '0.40'; +$VERSION = '0.41'; use Exporter; @ISA = qw( bigint ); @EXPORT_OK = qw( PI e bexp bpi hex oct ); diff --git a/dist/bignum/lib/bigrat.pm b/cpan/bignum/lib/bigrat.pm similarity index 99% rename from dist/bignum/lib/bigrat.pm rename to cpan/bignum/lib/bigrat.pm index 61b6526..11cb6cd 100644 --- a/dist/bignum/lib/bigrat.pm +++ b/cpan/bignum/lib/bigrat.pm @@ -1,7 +1,7 @@ package bigrat; use 5.006; -$VERSION = '0.40'; +$VERSION = '0.41'; require Exporter; @ISA = qw( bigint ); @EXPORT_OK = qw( PI e bpi bexp hex oct ); diff --git a/cpan/bignum/t/auth-bigint-hex.t b/cpan/bignum/t/auth-bigint-hex.t new file mode 100644 index 0000000..76a38de --- /dev/null +++ b/cpan/bignum/t/auth-bigint-hex.t @@ -0,0 +1,49 @@ +#!perl + +BEGIN { + unless ($ENV{AUTHOR_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +use strict; +use warnings; + +use Test::More tests => 507068; + +use Algorithm::Combinatorics qw< variations >; + +use bigint; + +use Test::More; + +my $elements = ['0', 'b', 'x', '1', '1', '_', '_', '9', 'z']; + +for my $k (0 .. @$elements) { + my $seen = {}; + for my $variation (variations($elements, $k)) { + my $str = join "", @$variation; + next if $seen -> {$str}++; + print qq|#\n# hex("$str")\n#\n|; + + my $i; + my @warnings; + local $SIG{__WARN__} = sub { + my $warning = shift; + $warning =~ s/ at .*\z//s; + $warnings[$i] = $warning; + }; + + $i = 0; + my $want_val = CORE::hex("$str"); + my $want_warn = $warnings[$i]; + + $i = 1; + my $got_val = bigint::hex("$str"); + my $got_warn = $warnings[$i]; + + is($got_val, $want_val, qq|hex("$str") (output)|); + is($got_warn, $want_warn, qq|hex("$str") (warning)|); + } +} diff --git a/cpan/bignum/t/auth-bigint-oct.t b/cpan/bignum/t/auth-bigint-oct.t new file mode 100644 index 0000000..06ecffc --- /dev/null +++ b/cpan/bignum/t/auth-bigint-oct.t @@ -0,0 +1,49 @@ +#!perl + +BEGIN { + unless ($ENV{AUTHOR_TESTING}) { + require Test::More; + Test::More::plan(skip_all => 'these tests are for release candidate testing'); + } +} + +use strict; +use warnings; + +use Test::More tests => 507068; + +use Algorithm::Combinatorics qw< variations >; + +use bigint; + +use Test::More; + +my $elements = ['0', 'b', 'x', '1', '1', '_', '_', '9', 'z']; + +for my $k (0 .. @$elements) { + my $seen = {}; + for my $variation (variations($elements, $k)) { + my $str = join "", @$variation; + next if $seen -> {$str}++; + print qq|#\n# oct("$str")\n#\n|; + + my $i; + my @warnings; + local $SIG{__WARN__} = sub { + my $warning = shift; + $warning =~ s/ at .*\z//s; + $warnings[$i] = $warning; + }; + + $i = 0; + my $want_val = CORE::oct("$str"); + my $want_warn = $warnings[$i]; + + $i = 1; + my $got_val = bigint::oct("$str"); + my $got_warn = $warnings[$i]; + + is($got_val, $want_val, qq|hex("$str") (output)|); + is($got_warn, $want_warn, qq|hex("$str") (warning)|); + } +} diff --git a/dist/bignum/t/big_e_pi.t b/cpan/bignum/t/big_e_pi.t similarity index 100% rename from dist/bignum/t/big_e_pi.t rename to cpan/bignum/t/big_e_pi.t diff --git a/dist/bignum/t/bigexp.t b/cpan/bignum/t/bigexp.t similarity index 100% rename from dist/bignum/t/bigexp.t rename to cpan/bignum/t/bigexp.t diff --git a/dist/bignum/t/bigint.t b/cpan/bignum/t/bigint.t similarity index 100% rename from dist/bignum/t/bigint.t rename to cpan/bignum/t/bigint.t diff --git a/dist/bignum/t/bignum.t b/cpan/bignum/t/bignum.t similarity index 100% rename from dist/bignum/t/bignum.t rename to cpan/bignum/t/bignum.t diff --git a/dist/bignum/t/bigrat.t b/cpan/bignum/t/bigrat.t similarity index 100% rename from dist/bignum/t/bigrat.t rename to cpan/bignum/t/bigrat.t diff --git a/dist/bignum/t/bii_e_pi.t b/cpan/bignum/t/bii_e_pi.t similarity index 100% rename from dist/bignum/t/bii_e_pi.t rename to cpan/bignum/t/bii_e_pi.t diff --git a/dist/bignum/t/biinfnan.t b/cpan/bignum/t/biinfnan.t similarity index 100% rename from dist/bignum/t/biinfnan.t rename to cpan/bignum/t/biinfnan.t diff --git a/dist/bignum/t/bir_e_pi.t b/cpan/bignum/t/bir_e_pi.t similarity index 100% rename from dist/bignum/t/bir_e_pi.t rename to cpan/bignum/t/bir_e_pi.t diff --git a/dist/bignum/t/bn_lite.t b/cpan/bignum/t/bn_lite.t similarity index 100% rename from dist/bignum/t/bn_lite.t rename to cpan/bignum/t/bn_lite.t diff --git a/dist/bignum/t/bninfnan.t b/cpan/bignum/t/bninfnan.t similarity index 100% rename from dist/bignum/t/bninfnan.t rename to cpan/bignum/t/bninfnan.t diff --git a/dist/bignum/t/br_lite.t b/cpan/bignum/t/br_lite.t similarity index 100% rename from dist/bignum/t/br_lite.t rename to cpan/bignum/t/br_lite.t diff --git a/dist/bignum/t/brinfnan.t b/cpan/bignum/t/brinfnan.t similarity index 100% rename from dist/bignum/t/brinfnan.t rename to cpan/bignum/t/brinfnan.t diff --git a/dist/bignum/t/in_effect.t b/cpan/bignum/t/in_effect.t similarity index 100% rename from dist/bignum/t/in_effect.t rename to cpan/bignum/t/in_effect.t diff --git a/dist/bignum/t/infnan.inc b/cpan/bignum/t/infnan.inc similarity index 100% rename from dist/bignum/t/infnan.inc rename to cpan/bignum/t/infnan.inc diff --git a/dist/bignum/t/option_a.t b/cpan/bignum/t/option_a.t similarity index 100% rename from dist/bignum/t/option_a.t rename to cpan/bignum/t/option_a.t diff --git a/dist/bignum/t/option_l.t b/cpan/bignum/t/option_l.t similarity index 100% rename from dist/bignum/t/option_l.t rename to cpan/bignum/t/option_l.t diff --git a/dist/bignum/t/option_p.t b/cpan/bignum/t/option_p.t similarity index 100% rename from dist/bignum/t/option_p.t rename to cpan/bignum/t/option_p.t diff --git a/dist/bignum/t/overrides.t b/cpan/bignum/t/overrides.t similarity index 100% rename from dist/bignum/t/overrides.t rename to cpan/bignum/t/overrides.t diff --git a/dist/bignum/t/ratopt_a.t b/cpan/bignum/t/ratopt_a.t similarity index 100% rename from dist/bignum/t/ratopt_a.t rename to cpan/bignum/t/ratopt_a.t diff --git a/dist/bignum/t/scope_f.t b/cpan/bignum/t/scope_f.t similarity index 100% rename from dist/bignum/t/scope_f.t rename to cpan/bignum/t/scope_f.t diff --git a/dist/bignum/t/scope_i.t b/cpan/bignum/t/scope_i.t similarity index 100% rename from dist/bignum/t/scope_i.t rename to cpan/bignum/t/scope_i.t diff --git a/dist/bignum/t/scope_r.t b/cpan/bignum/t/scope_r.t similarity index 100% rename from dist/bignum/t/scope_r.t rename to cpan/bignum/t/scope_r.t diff --git a/cpan/experimental/lib/experimental.pm b/cpan/experimental/lib/experimental.pm index ec9807c..8d74751 100644 --- a/cpan/experimental/lib/experimental.pm +++ b/cpan/experimental/lib/experimental.pm @@ -1,5 +1,5 @@ package experimental; -$experimental::VERSION = '0.014'; +$experimental::VERSION = '0.016'; use strict; use warnings; use version (); @@ -38,7 +38,12 @@ my %min_version = ( unicode_eval => '5.16.0', unicode_strings => '5.12.0', ); +my %max_version = ( + lexical_topic => '5.23.4', +); + $_ = version->new($_) for values %min_version; +$_ = version->new($_) for values %max_version; my %additional = ( postderef => ['postderef_qq'], @@ -59,7 +64,7 @@ sub _enable { elsif (not exists $min_version{$pragma}) { croak "Can't enable unknown feature $pragma"; } - elsif ($min_version{$pragma} > $]) { + elsif ($] < $min_version{$pragma}) { my $stable = $min_version{$pragma}; if ($stable->{version}[1] % 2) { $stable = version->new( @@ -68,6 +73,9 @@ sub _enable { } croak "Need perl $stable or later for feature $pragma"; } + elsif ($] >= ($max_version{$pragma} || 7)) { + croak "Experimental feature $pragma has been removed from perl in version $max_version{$pragma}"; + } } sub import { @@ -120,7 +128,7 @@ experimental - Experimental features made easy =head1 VERSION -version 0.014 +version 0.016 =head1 SYNOPSIS diff --git a/cpan/experimental/t/basic.t b/cpan/experimental/t/basic.t index ee03a02..a270fdf 100644 --- a/cpan/experimental/t/basic.t +++ b/cpan/experimental/t/basic.t @@ -5,10 +5,10 @@ use Test::More 0.89; local $SIG{__WARN__} = sub { fail("Got unexpected warning"); diag($_[0]) }; if ($] >= 5.010000) { - is (eval <<'END', 1, 'lexical topic compiles') or diag $@; - use experimental 'lexical_topic'; - my $_ = 1; - is($_, 1, '$_ is 1'); + is (eval <<'END', 1, 'state compiles') or diag $@; + use experimental 'state'; + state $foo = 1; + is($foo, 1, '$foo is 1'); 1; END } diff --git a/dist/ExtUtils-CBuilder/Changes b/dist/ExtUtils-CBuilder/Changes index ab8496e..27f3bc3 100644 --- a/dist/ExtUtils-CBuilder/Changes +++ b/dist/ExtUtils-CBuilder/Changes @@ -1,5 +1,11 @@ Revision history for Perl extension ExtUtils::CBuilder. +0.282224 - 2015-10-09 + + Enhncements: + + - Use warnings/strict on all modules. + 0.280223 - 2015-06-02 Fixed: diff --git a/dist/ExtUtils-CBuilder/Makefile.PL b/dist/ExtUtils-CBuilder/Makefile.PL index 13734c5..820b294 100644 --- a/dist/ExtUtils-CBuilder/Makefile.PL +++ b/dist/ExtUtils-CBuilder/Makefile.PL @@ -1,4 +1,4 @@ -# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.036. +# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.039. use strict; use warnings; @@ -13,7 +13,6 @@ my %WriteMakefileArgs = ( "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "ExtUtils-CBuilder", - "EXE_FILES" => [], "LICENSE" => "perl", "NAME" => "ExtUtils::CBuilder", "PREREQ_PM" => { @@ -30,7 +29,7 @@ my %WriteMakefileArgs = ( "TEST_REQUIRES" => { "Test::More" => "0.47" }, - "VERSION" => "0.280223", + "VERSION" => "0.280224", "test" => { "TESTS" => "t/*.t" } diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm index 9e60d08..abe976e 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm @@ -1,10 +1,12 @@ package ExtUtils::CBuilder; -$ExtUtils::CBuilder::VERSION = '0.280223'; +$ExtUtils::CBuilder::VERSION = '0.280224'; use File::Spec (); use File::Path (); use File::Basename (); use Perl::OSType qw/os_type/; +use warnings; +use strict; use vars qw(@ISA); # We only use this once - don't waste a symbol table entry on it. @@ -18,17 +20,18 @@ my $load = sub { { my @package = split /::/, __PACKAGE__; - + my $ostype = os_type(); if (grep {-e File::Spec->catfile($_, @package, 'Platform', $^O) . '.pm'} @INC) { - $load->(__PACKAGE__ . "::Platform::$^O"); - - } elsif ( $ostype && grep {-e File::Spec->catfile($_, @package, 'Platform', $ostype) . '.pm'} @INC) { - $load->(__PACKAGE__ . "::Platform::$ostype"); - + $load->(__PACKAGE__ . "::Platform::$^O"); + + } elsif ( $ostype && + grep {-e File::Spec->catfile($_, @package, 'Platform', $ostype) . '.pm'} @INC) { + $load->(__PACKAGE__ . "::Platform::$ostype"); + } else { - $load->(__PACKAGE__ . "::Base"); + $load->(__PACKAGE__ . "::Base"); } } diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm index 932657d..eb4c175 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm @@ -1,6 +1,7 @@ package ExtUtils::CBuilder::Base; -$ExtUtils::CBuilder::Base::VERSION = '0.280223'; +$ExtUtils::CBuilder::Base::VERSION = '0.280224'; use strict; +use warnings; use File::Spec; use File::Basename; use Cwd (); diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm index dcd0562..d6c1768 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm @@ -1,5 +1,6 @@ package ExtUtils::CBuilder::Platform::Unix; -$ExtUtils::CBuilder::Platform::Unix::VERSION = '0.280223'; +$ExtUtils::CBuilder::Platform::Unix::VERSION = '0.280224'; +use warnings; use strict; use ExtUtils::CBuilder::Base; @@ -20,19 +21,19 @@ sub link_executable { sub link { my $self = shift; my $cf = $self->{config}; - + # Some platforms (notably Mac OS X 10.3, but some others too) expect # the syntax "FOO=BAR /bin/command arg arg" to work in %Config # (notably $Config{ld}). It usually works in system(SCALAR), but we # use system(LIST). We fix it up here with 'env'. - + local $cf->{ld} = $cf->{ld}; if (ref $cf->{ld}) { unshift @{$cf->{ld}}, 'env' if $cf->{ld}[0] =~ /^\s*\w+=/; } else { $cf->{ld} =~ s/^(\s*\w+=)/env $1/; } - + return $self->SUPER::link(@_); } diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm index bfdc0d4..194d888 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm @@ -1,5 +1,6 @@ package ExtUtils::CBuilder::Platform::VMS; -$ExtUtils::CBuilder::Platform::VMS::VERSION = '0.280223'; +$ExtUtils::CBuilder::Platform::VMS::VERSION = '0.280224'; +use warnings; use strict; use ExtUtils::CBuilder::Base; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm index 5b870bb..b95592d 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm @@ -1,5 +1,5 @@ package ExtUtils::CBuilder::Platform::Windows; -$ExtUtils::CBuilder::Platform::Windows::VERSION = '0.280223'; +$ExtUtils::CBuilder::Platform::Windows::VERSION = '0.280224'; use strict; use warnings; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm index 2f37117..cd93b72 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm @@ -1,5 +1,8 @@ package ExtUtils::CBuilder::Platform::Windows::BCC; -$ExtUtils::CBuilder::Platform::Windows::BCC::VERSION = '0.280223'; +$ExtUtils::CBuilder::Platform::Windows::BCC::VERSION = '0.280224'; +use strict; +use warnings; + sub format_compiler_cmd { my ($self, %spec) = @_; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm index 818ec36..5f219f2 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm @@ -1,5 +1,8 @@ package ExtUtils::CBuilder::Platform::Windows::GCC; -$ExtUtils::CBuilder::Platform::Windows::GCC::VERSION = '0.280223'; +$ExtUtils::CBuilder::Platform::Windows::GCC::VERSION = '0.280224'; +use warnings; +use strict; + sub format_compiler_cmd { my ($self, %spec) = @_; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm index 552e45c..f14988e 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm @@ -1,5 +1,8 @@ package ExtUtils::CBuilder::Platform::Windows::MSVC; -$ExtUtils::CBuilder::Platform::Windows::MSVC::VERSION = '0.280223'; +$ExtUtils::CBuilder::Platform::Windows::MSVC::VERSION = '0.280224'; +use warnings; +use strict; + sub arg_exec_file { my ($self, $file) = @_; return "/OUT:$file"; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm index 1a2848e..949ef53 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm @@ -1,5 +1,6 @@ package ExtUtils::CBuilder::Platform::aix; -$ExtUtils::CBuilder::Platform::aix::VERSION = '0.280223'; +$ExtUtils::CBuilder::Platform::aix::VERSION = '0.280224'; +use warnings; use strict; use ExtUtils::CBuilder::Platform::Unix; use File::Spec; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm index 0942b3c..5940922 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm @@ -1,5 +1,6 @@ package ExtUtils::CBuilder::Platform::android; -$ExtUtils::CBuilder::Platform::android::VERSION = '0.280223'; +$ExtUtils::CBuilder::Platform::android::VERSION = '0.280224'; +use warnings; use strict; use File::Spec; use ExtUtils::CBuilder::Platform::Unix; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm index 259fbc6..c020e44 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm @@ -1,5 +1,6 @@ package ExtUtils::CBuilder::Platform::cygwin; -$ExtUtils::CBuilder::Platform::cygwin::VERSION = '0.280223'; +$ExtUtils::CBuilder::Platform::cygwin::VERSION = '0.280224'; +use warnings; use strict; use File::Spec; use ExtUtils::CBuilder::Platform::Unix; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm index 94af5ee..324c268 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm @@ -1,5 +1,6 @@ package ExtUtils::CBuilder::Platform::darwin; -$ExtUtils::CBuilder::Platform::darwin::VERSION = '0.280223'; +$ExtUtils::CBuilder::Platform::darwin::VERSION = '0.280224'; +use warnings; use strict; use ExtUtils::CBuilder::Platform::Unix; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm index 0d03ecc..0eb098f 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm @@ -1,5 +1,6 @@ package ExtUtils::CBuilder::Platform::dec_osf; -$ExtUtils::CBuilder::Platform::dec_osf::VERSION = '0.280223'; +$ExtUtils::CBuilder::Platform::dec_osf::VERSION = '0.280224'; +use warnings; use strict; use ExtUtils::CBuilder::Platform::Unix; use File::Spec; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm index 3129ed9..19047b9 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm @@ -1,5 +1,6 @@ package ExtUtils::CBuilder::Platform::os2; -$ExtUtils::CBuilder::Platform::os2::VERSION = '0.280223'; +$ExtUtils::CBuilder::Platform::os2::VERSION = '0.280224'; +use warnings; use strict; use ExtUtils::CBuilder::Platform::Unix; diff --git a/dist/IO/IO.pm b/dist/IO/IO.pm index 2762958..de3e991 100644 --- a/dist/IO/IO.pm +++ b/dist/IO/IO.pm @@ -7,7 +7,7 @@ use Carp; use strict; use warnings; -our $VERSION = "1.35"; +our $VERSION = "1.36"; XSLoader::load 'IO', $VERSION; sub import { diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs index 1f546b9..fe749a6 100644 --- a/dist/IO/IO.xs +++ b/dist/IO/IO.xs @@ -319,7 +319,10 @@ PPCODE: #ifdef HAS_POLL const int nfd = (items - 1) / 2; SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd)); - struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv); + /* We should pass _some_ valid pointer even if nfd is zero, but it + * doesn't matter what it is, since we're telling it to not check any fds. + */ + struct pollfd *fds = nfd ? (struct pollfd *)SvPVX(tmpsv) : (struct pollfd *)tmpsv; int i,j,ret; for(i=1, j=0 ; j < nfd ; j++) { fds[j].fd = SvIV(ST(i)); diff --git a/dist/IO/lib/IO/Poll.pm b/dist/IO/lib/IO/Poll.pm index 47f1a13..a02dc3d 100644 --- a/dist/IO/lib/IO/Poll.pm +++ b/dist/IO/lib/IO/Poll.pm @@ -13,7 +13,7 @@ use Exporter (); our(@ISA, @EXPORT_OK, @EXPORT, $VERSION); @ISA = qw(Exporter); -$VERSION = "0.09"; +$VERSION = "0.10"; @EXPORT = qw( POLLIN POLLOUT @@ -83,7 +83,7 @@ sub poll { push(@poll,$fd => $mask); } - my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0; + my $ret = _poll(defined($timeout) ? $timeout * 1000 : -1,@poll); return $ret unless $ret > 0; diff --git a/dist/IO/poll.h b/dist/IO/poll.h index 634bcdd..08de250 100644 --- a/dist/IO/poll.h +++ b/dist/IO/poll.h @@ -12,6 +12,8 @@ #if (defined(HAS_POLL) && defined(I_POLL)) || defined(POLLWRBAND) # include +#elif (defined(HAS_POLL) && defined(I_SYS_POLL)) +# include #else #ifdef HAS_SELECT diff --git a/dist/IO/t/io_poll.t b/dist/IO/t/io_poll.t index 364d346..c58467c 100644 --- a/dist/IO/t/io_poll.t +++ b/dist/IO/t/io_poll.t @@ -8,7 +8,7 @@ if ($^O eq 'mpeix') { select(STDERR); $| = 1; select(STDOUT); $| = 1; -print "1..10\n"; +print "1..12\n"; use IO::Handle; use IO::Poll qw(/POLL/); @@ -81,3 +81,12 @@ close STDIN; print "not " if $poll->poll(0.1); print "ok 10\n"; + +my $wait = IO::Poll->new; +my $now = time; +my $zero = $wait->poll(2); +my $diff = time - $now; +print "not " if !defined($zero) or $zero; +print "ok 11\n"; +print "not " unless $diff >= 2; +print "ok 12\n"; diff --git a/dist/Module-CoreList/Changes b/dist/Module-CoreList/Changes index 96e0e4c..0bc5c8c 100644 --- a/dist/Module-CoreList/Changes +++ b/dist/Module-CoreList/Changes @@ -1,3 +1,6 @@ +5.20151020 + - Updated for v5.23.4 + 5.20150920 - Updated for v5.23.3 diff --git a/dist/Module-CoreList/lib/Module/CoreList.pm b/dist/Module-CoreList/lib/Module/CoreList.pm index 48f53a9..14ee108 100644 --- a/dist/Module-CoreList/lib/Module/CoreList.pm +++ b/dist/Module-CoreList/lib/Module/CoreList.pm @@ -4,7 +4,7 @@ use vars qw/$VERSION %released %version %families %upstream %bug_tracker %deprecated %delta/; use Module::CoreList::TieHashDelta; use version; -$VERSION = '5.20150920'; +$VERSION = '5.20151020'; sub _released_order { # Sort helper, to make '?' sort after everything else (substr($released{$a}, 0, 1) eq "?") @@ -284,6 +284,7 @@ sub changes_between { 5.023002 => '2015-08-20', 5.020003 => '2015-09-12', 5.023003 => '2015-09-20', + 5.023004 => '2015-10-20', ); for my $version ( sort { $a <=> $b } keys %released ) { @@ -11833,6 +11834,87 @@ for my $version ( sort { $a <=> $b } keys %released ) { removed => { } }, + 5.023004 => { + delta_from => 5.023003, + changed => { + 'B' => '1.60', + 'B::Op_private' => '5.023004', + 'Compress::Raw::Bzip2' => '2.069', + 'Compress::Raw::Zlib' => '2.069', + 'Compress::Zlib' => '2.069', + 'Config' => '5.023004', + 'Devel::PPPort' => '3.32', + 'DynaLoader' => '1.35', + 'Encode' => '2.78', + 'ExtUtils::CBuilder' => '0.280224', + 'ExtUtils::CBuilder::Base'=> '0.280224', + 'ExtUtils::CBuilder::Platform::Unix'=> '0.280224', + 'ExtUtils::CBuilder::Platform::VMS'=> '0.280224', + 'ExtUtils::CBuilder::Platform::Windows'=> '0.280224', + 'ExtUtils::CBuilder::Platform::Windows::BCC'=> '0.280224', + 'ExtUtils::CBuilder::Platform::Windows::GCC'=> '0.280224', + 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> '0.280224', + 'ExtUtils::CBuilder::Platform::aix'=> '0.280224', + 'ExtUtils::CBuilder::Platform::android'=> '0.280224', + 'ExtUtils::CBuilder::Platform::cygwin'=> '0.280224', + 'ExtUtils::CBuilder::Platform::darwin'=> '0.280224', + 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.280224', + 'ExtUtils::CBuilder::Platform::os2'=> '0.280224', + 'File::Path' => '2.12', + 'IO' => '1.36', + 'IO::Compress::Adapter::Bzip2'=> '2.069', + 'IO::Compress::Adapter::Deflate'=> '2.069', + 'IO::Compress::Adapter::Identity'=> '2.069', + 'IO::Compress::Base' => '2.069', + 'IO::Compress::Base::Common'=> '2.069', + 'IO::Compress::Bzip2' => '2.069', + 'IO::Compress::Deflate' => '2.069', + 'IO::Compress::Gzip' => '2.069', + 'IO::Compress::Gzip::Constants'=> '2.069', + 'IO::Compress::RawDeflate'=> '2.069', + 'IO::Compress::Zip' => '2.069', + 'IO::Compress::Zip::Constants'=> '2.069', + 'IO::Compress::Zlib::Constants'=> '2.069', + 'IO::Compress::Zlib::Extra'=> '2.069', + 'IO::Poll' => '0.10', + 'IO::Uncompress::Adapter::Bunzip2'=> '2.069', + 'IO::Uncompress::Adapter::Identity'=> '2.069', + 'IO::Uncompress::Adapter::Inflate'=> '2.069', + 'IO::Uncompress::AnyInflate'=> '2.069', + 'IO::Uncompress::AnyUncompress'=> '2.069', + 'IO::Uncompress::Base' => '2.069', + 'IO::Uncompress::Bunzip2'=> '2.069', + 'IO::Uncompress::Gunzip'=> '2.069', + 'IO::Uncompress::Inflate'=> '2.069', + 'IO::Uncompress::RawInflate'=> '2.069', + 'IO::Uncompress::Unzip' => '2.069', + 'Math::BigFloat' => '1.999704', + 'Math::BigFloat::Trace' => '0.41', + 'Math::BigInt' => '1.999704', + 'Math::BigInt::Calc' => '1.999704', + 'Math::BigInt::CalcEmu' => '1.999704', + 'Math::BigInt::FastCalc'=> '0.34', + 'Math::BigInt::Trace' => '0.41', + 'Module::CoreList' => '5.20151020', + 'Module::CoreList::TieHashDelta'=> '5.20151020', + 'Module::CoreList::Utils'=> '5.20151020', + 'Module::Metadata' => '1.000029', + 'POSIX' => '1.58', + 'Perl::OSType' => '1.009', + 'PerlIO::encoding' => '0.22', + 'Socket' => '2.020_02', + 'Unicode::Normalize' => '1.21', + 'XS::APItest' => '0.76', + 'bigint' => '0.41', + 'bignum' => '0.41', + 'bigrat' => '0.41', + 'experimental' => '0.016', + 'if' => '0.0606', + 'warnings' => '1.35', + }, + removed => { + } + }, ); sub is_core @@ -12424,6 +12506,13 @@ for my $version (sort { $a <=> $b } keys %delta) { removed => { } }, + 5.023004 => { + delta_from => 5.023003, + changed => { + }, + removed => { + } + }, ); for my $version (sort { $a <=> $b } keys %deprecated) { @@ -12641,10 +12730,12 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'MIME::Base64' => 'cpan', 'MIME::QuotedPrint' => 'cpan', 'Math::BigFloat' => 'cpan', + 'Math::BigFloat::Trace' => 'cpan', 'Math::BigInt' => 'cpan', 'Math::BigInt::Calc' => 'cpan', 'Math::BigInt::CalcEmu' => 'cpan', 'Math::BigInt::FastCalc'=> 'cpan', + 'Math::BigInt::Trace' => 'cpan', 'Math::BigRat' => 'cpan', 'Math::Complex' => 'cpan', 'Math::Trig' => 'cpan', @@ -12831,6 +12922,9 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'autodie::exception::system'=> 'cpan', 'autodie::hints' => 'cpan', 'autodie::skip' => 'cpan', + 'bigint' => 'cpan', + 'bignum' => 'cpan', + 'bigrat' => 'cpan', 'encoding' => 'cpan', 'encoding::warnings' => 'cpan', 'experimental' => 'cpan', @@ -13047,10 +13141,12 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'MIME::Base64' => undef, 'MIME::QuotedPrint' => undef, 'Math::BigFloat' => undef, + 'Math::BigFloat::Trace' => undef, 'Math::BigInt' => undef, 'Math::BigInt::Calc' => undef, 'Math::BigInt::CalcEmu' => undef, 'Math::BigInt::FastCalc'=> undef, + 'Math::BigInt::Trace' => undef, 'Math::BigRat' => undef, 'Math::Complex' => undef, 'Math::Trig' => undef, @@ -13086,7 +13182,7 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'Net::Time' => undef, 'Params::Check' => undef, 'Parse::CPAN::Meta' => 'https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta/issues', - 'Perl::OSType' => 'https://github.com/dagolden/Perl-OSType/issues', + 'Perl::OSType' => 'https://github.com/Perl-Toolchain-Gang/Perl-OSType/issues', 'PerlIO::via::QuotedPrint'=> undef, 'Pod::Checker' => undef, 'Pod::Escapes' => undef, @@ -13237,6 +13333,9 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'autodie::exception::system'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie', 'autodie::hints' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie', 'autodie::skip' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie', + 'bigint' => undef, + 'bignum' => undef, + 'bigrat' => undef, 'encoding' => undef, 'encoding::warnings' => undef, 'experimental' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=experimental', diff --git a/dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm b/dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm index e6e5c91..6555667 100644 --- a/dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm +++ b/dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm @@ -3,7 +3,7 @@ package Module::CoreList::TieHashDelta; use strict; use vars qw($VERSION); -$VERSION = '5.20150920'; +$VERSION = '5.20151020'; sub TIEHASH { my ($class, $changed, $removed, $parent) = @_; diff --git a/dist/Module-CoreList/lib/Module/CoreList/Utils.pm b/dist/Module-CoreList/lib/Module/CoreList/Utils.pm index 2775586..bf9a36f 100644 --- a/dist/Module-CoreList/lib/Module/CoreList/Utils.pm +++ b/dist/Module-CoreList/lib/Module/CoreList/Utils.pm @@ -6,7 +6,7 @@ use vars qw[$VERSION %utilities]; use Module::CoreList; use Module::CoreList::TieHashDelta; -$VERSION = '5.20150920'; +$VERSION = '5.20151020'; sub utilities { my $perl = shift; @@ -1087,6 +1087,13 @@ my %delta = ( removed => { } }, + 5.023004 => { + delta_from => 5.023003, + changed => { + }, + removed => { + } + }, ); for my $version (sort { $a <=> $b } keys %delta) { diff --git a/dist/if/Changes b/dist/if/Changes new file mode 100644 index 0000000..9956862 --- /dev/null +++ b/dist/if/Changes @@ -0,0 +1,50 @@ +Revision history for Perl extension if. + +0.0606 2015-10-01 + - add license information to pod + +0.0605 2015-09-20 (perl v5.23.3) + - Better failure message for 'no if': It previously always + said 'use if', even if 'no if' was what was specified (Karl + Williamson) + +0.0604 2015-04-20 (perl v5.21.11) + - Note that works with 'no' besides 'use' (Karl Williamson) + +0.0603 2013-07-22 (perl v5.19.2) + - Added example usage and SEE ALSO links to similar modules in + doc for if.pm (Neil Bowers) + +0.0602 2011-12-20 (perl v5.15.6) + - Convert if's test to Test::More (Nicholas Clark) + - Convert ` to '. (RT #36079, Jim Keenan) + +0.0601 2010-12-20 (perl v5.13.8) + - The update of 0.0401 was lost during update to 0.05 + +0.06 2010-10-20 (perl v5.13.6) + - Update email address. + +0.05 2006-01-28 (perl v5.9.3) + - Sync with perl5.12.2: + - Better error handling. + - Suggest significance of => in the docs. + +0.0401 2004-03-16 (perl v5.9.1) + - test was using a discipline for open.pm not supported with + older versions of Perl. + +0.04 2003-10-30 (CPAN-only release) + - support package names which are simultaneously keywords (open). + fix `require or die'. + +0.03 2003-09-25 (perl v5.8.5) + - ? + +0.010001 2002-04-14 (CPAN-only release) + - `our' removed for backward-compatibility. + - test adopted for backward-compatibility + +0.01 2002-03-05 (perl v5.7.3) + - The version of 5.7.3. + diff --git a/dist/if/if.pm b/dist/if/if.pm index a18f8fc..1985df4 100644 --- a/dist/if/if.pm +++ b/dist/if/if.pm @@ -1,6 +1,6 @@ package if; -$VERSION = '0.0605'; +$VERSION = '0.0606'; sub work { my $method = shift() ? 'import' : 'unimport'; @@ -103,4 +103,11 @@ based on what version of Perl is running. Ilya Zakharevich L. +=head1 COPYRIGHT AND LICENCE + +This software is copyright (c) 2002 by Ilya Zakharevich. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + =cut diff --git a/doio.c b/doio.c index 6bceb29..5ebb7f1 100644 --- a/doio.c +++ b/doio.c @@ -835,6 +835,7 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) if (!GvAV(gv)) return NULL; while (av_tindex(GvAV(gv)) >= 0) { + Stat_t statbuf; STRLEN oldlen; SV *const sv = av_shift(GvAV(gv)); SAVEFREESV(sv); @@ -976,13 +977,13 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) setdefout(PL_argvoutgv); PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv))); if (PL_lastfd >= 0) { - (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf); + (void)PerlLIO_fstat(PL_lastfd,&statbuf); #ifdef HAS_FCHMOD (void)fchmod(PL_lastfd,PL_filemode); #else (void)PerlLIO_chmod(PL_oldname,PL_filemode); #endif - if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) { + if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) { /* XXX silently ignore failures */ #ifdef HAS_FCHOWN PERL_UNUSED_RESULT(fchown(PL_lastfd,fileuid,filegid)); @@ -999,8 +1000,8 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) if (ckWARN_d(WARN_INPLACE)) { const int eno = errno; - if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0 - && !S_ISREG(PL_statbuf.st_mode)) { + if (PerlLIO_stat(PL_oldname, &statbuf) >= 0 + && !S_ISREG(statbuf.st_mode)) { Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit: %s is not a regular file", PL_oldname); @@ -1934,11 +1935,12 @@ nothing in the core. #endif } else { /* don't let root wipe out directories without -U */ - if (PerlLIO_lstat(s,&PL_statbuf) < 0) - tot--; - else if (S_ISDIR(PL_statbuf.st_mode)) { + Stat_t statbuf; + if (PerlLIO_lstat(s, &statbuf) < 0) tot--; + else if (S_ISDIR(statbuf.st_mode)) { SETERRNO(EISDIR, SS_NOPRIV); + tot--; } else { if (UNLINK(s)) @@ -2514,7 +2516,8 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) Function called by C to spawn a glob (or do the glob inside perl on VMS). This code used to be inline, but now perl uses C -this glob starter is only used by miniperl during the build process. +this glob starter is only used by miniperl during the build process, +or when PERL_EXTERNAL_GLOB is defined. Moving it away shrinks F; shrinking F helps speed perl up. =cut diff --git a/doop.c b/doop.c index 19fe310..5dbd8a2 100644 --- a/doop.c +++ b/doop.c @@ -1220,6 +1220,7 @@ Perl_do_kv(pTHX) dSP; HV * const keys = MUTABLE_HV(POPs); HE *entry; + SSize_t extend_size; const I32 gimme = GIMME_V; const I32 dokv = (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV); /* op_type is OP_RKEYS/OP_RVALUES if pp_rkeys delegated to here */ @@ -1255,7 +1256,10 @@ Perl_do_kv(pTHX) RETURN; } - EXTEND(SP, HvUSEDKEYS(keys) * (dokeys + dovalues)); + /* 2*HvUSEDKEYS() should never be big enough to truncate or wrap */ + assert(HvUSEDKEYS(keys) <= (SSize_t_MAX >> 1)); + extend_size = (SSize_t)HvUSEDKEYS(keys) * (dokeys + dovalues); + EXTEND(SP, extend_size); while ((entry = hv_iternext(keys))) { if (dokeys) { diff --git a/embed.fnc b/embed.fnc index d9b43d1..096a92e 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1374,7 +1374,7 @@ Apd |I32 |sv_true |NULLOK SV *const sv sd |void |sv_add_arena |NN char *const ptr|const U32 size \ |const U32 flags #endif -Apdn |int |sv_backoff |NN SV *const sv +Apdn |void |sv_backoff |NN SV *const sv Apd |SV* |sv_bless |NN SV *const sv|NN HV *const stash #if defined(PERL_DEBUG_READONLY_COW) p |void |sv_buf_to_ro |NN SV *sv @@ -2162,13 +2162,14 @@ Es |U32 |join_exact |NN RExC_state_t *pRExC_state \ |NN regnode *scan|NN UV *min_subtract \ |NN bool *unfolded_multi_char \ |U32 flags|NULLOK regnode *val|U32 depth -EsRn |char * |regpatws |NN RExC_state_t *pRExC_state \ - |NN char *p|const bool recognize_comment Ei |void |alloc_maybe_populate_EXACT|NN RExC_state_t *pRExC_state \ |NN regnode *node|NN I32 *flagp|STRLEN len \ |UV code_point|bool downgradable Ein |U8 |compute_EXACTish|NN RExC_state_t *pRExC_state -Es |char * |nextchar |NN RExC_state_t *pRExC_state +Es |void |nextchar |NN RExC_state_t *pRExC_state +Es |void |skip_to_be_ignored_text|NN RExC_state_t *pRExC_state \ + |NN char ** p \ + |const bool force_to_xmod Ein |char * |reg_skipcomment|NN RExC_state_t *pRExC_state|NN char * p Es |void |scan_commit |NN const RExC_state_t *pRExC_state \ |NN struct scan_data_t *data \ @@ -2259,7 +2260,7 @@ ERs |I32 |regrepeat |NN regexp *prog|NN char **startposp \ |NN regmatch_info *const reginfo \ |I32 max \ |int depth -ERs |I32 |regtry |NN regmatch_info *reginfo|NN char **startposp +ERs |bool |regtry |NN regmatch_info *reginfo|NN char **startposp ERs |bool |reginclass |NULLOK regexp * const prog \ |NN const regnode * const n \ |NN const U8 * const p \ @@ -2606,8 +2607,6 @@ Apd |PADOFFSET|pad_findmy_pv|NN const char* name|U32 flags Apd |PADOFFSET|pad_findmy_sv|NN SV* name|U32 flags ApdD |PADOFFSET|find_rundefsvoffset | Apd |SV* |find_rundefsv | -: Used in pp.c -p |SV* |find_rundefsv2 |NN CV *cv|U32 seq #if defined(PERL_IN_PAD_C) sd |PADOFFSET|pad_findlex |NN const char *namepv|STRLEN namelen|U32 flags \ |NN const CV* cv|U32 seq|int warn \ diff --git a/embed.h b/embed.h index 3f6515f..5472b07 100644 --- a/embed.h +++ b/embed.h @@ -1003,12 +1003,12 @@ #define regex_set_precedence S_regex_set_precedence #define reginsert(a,b,c,d) S_reginsert(aTHX_ a,b,c,d) #define regnode_guts(a,b,c,d) S_regnode_guts(aTHX_ a,b,c,d) -#define regpatws S_regpatws #define regpiece(a,b,c) S_regpiece(aTHX_ a,b,c) #define regpposixcc(a,b,c) S_regpposixcc(aTHX_ a,b,c) #define regtail(a,b,c,d) S_regtail(aTHX_ a,b,c,d) #define scan_commit(a,b,c,d) S_scan_commit(aTHX_ a,b,c,d) #define set_ANYOF_arg(a,b,c,d,e,f,g) S_set_ANYOF_arg(aTHX_ a,b,c,d,e,f,g) +#define skip_to_be_ignored_text(a,b,c) S_skip_to_be_ignored_text(aTHX_ a,b,c) #define ssc_add_range(a,b,c) S_ssc_add_range(aTHX_ a,b,c) #define ssc_and(a,b,c) S_ssc_and(aTHX_ a,b,c) #define ssc_anything(a) S_ssc_anything(aTHX_ a) @@ -1184,7 +1184,6 @@ #define finalize_optree(a) Perl_finalize_optree(aTHX_ a) #define find_lexical_cv(a) Perl_find_lexical_cv(aTHX_ a) #define find_runcv_where(a,b,c) Perl_find_runcv_where(aTHX_ a,b,c) -#define find_rundefsv2(a,b) Perl_find_rundefsv2(aTHX_ a,b) #define find_script(a,b,c,d) Perl_find_script(aTHX_ a,b,c,d) #define free_tied_hv_pool() Perl_free_tied_hv_pool(aTHX) #define get_hash_seed(a) Perl_get_hash_seed(aTHX_ a) diff --git a/ext/B/B.pm b/ext/B/B.pm index 706e19a..13ab3c9 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -15,7 +15,7 @@ require Exporter; # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.59'; + $B::VERSION = '1.60'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. diff --git a/ext/B/B.xs b/ext/B/B.xs index 5d15d80..eb21103 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -1370,7 +1370,9 @@ aux_list(o, cv) PAD *comppad = PadlistARRAY(padlist)[1]; #endif - EXTEND(SP, len); + /* len should never be big enough to truncate or wrap */ + assert(len <= SSize_t_MAX); + EXTEND(SP, (SSize_t)len); PUSHs(sv_2mortal(newSViv(actions))); while (!last) { @@ -2139,8 +2141,12 @@ HvARRAY(hv) PPCODE: if (HvUSEDKEYS(hv) > 0) { HE *he; + SSize_t extend_size; (void)hv_iterinit(hv); - EXTEND(sp, HvUSEDKEYS(hv) * 2); + /* 2*HvUSEDKEYS() should never be big enough to truncate or wrap */ + assert(HvUSEDKEYS(hv) <= (SSize_t_MAX >> 1)); + extend_size = (SSize_t)HvUSEDKEYS(hv) * 2; + EXTEND(sp, extend_size); while ((he = hv_iternext(hv))) { if (HeSVKEY(he)) { mPUSHs(HeSVKEY(he)); diff --git a/ext/DynaLoader/DynaLoader_pm.PL b/ext/DynaLoader/DynaLoader_pm.PL index 45b932f..944ec9a 100644 --- a/ext/DynaLoader/DynaLoader_pm.PL +++ b/ext/DynaLoader/DynaLoader_pm.PL @@ -85,7 +85,7 @@ package DynaLoader; # Tim.Bunce@ig.co.uk, August 1994 BEGIN { - $VERSION = '1.34'; + $VERSION = '1.35'; } EOT @@ -422,7 +422,6 @@ sub bootstrap { } sub dl_findfile { - # Read ext/DynaLoader/DynaLoader.doc for detailed information. # This function does not automatically consider the architecture # or the perl library auto directories. my (@args) = @_; diff --git a/ext/DynaLoader/dl_dlopen.xs b/ext/DynaLoader/dl_dlopen.xs index 3dce1ef..d4fea89 100644 --- a/ext/DynaLoader/dl_dlopen.xs +++ b/ext/DynaLoader/dl_dlopen.xs @@ -171,10 +171,11 @@ dl_load_file(filename, flags=0) #if defined(DLOPEN_WONT_DO_RELATIVE_PATHS) char pathbuf[PATH_MAX + 2]; if (*filename != '/' && strchr(filename, '/')) { - if (getcwd(pathbuf, PATH_MAX - strlen(filename))) { - strcat(pathbuf, "/"); - strcat(pathbuf, filename); - filename = pathbuf; + const size_t filename_len = strlen(filename); + if (getcwd(pathbuf, PATH_MAX - filename_len)) { + const size_t path_len = strlen(pathbuf); + pathbuf[path_len] = '/'; + filename = (char *) memcpy(pathbuf + path_len + 1, filename, filename_len + 1); } } #endif diff --git a/ext/DynaLoader/t/DynaLoader.t b/ext/DynaLoader/t/DynaLoader.t index 3ac8d08..fe730b9 100644 --- a/ext/DynaLoader/t/DynaLoader.t +++ b/ext/DynaLoader/t/DynaLoader.t @@ -112,7 +112,7 @@ SKIP: { # (not at least by that name) that the dl_findfile() # could find. skip( "dl_findfile test not appropriate on $^O", 1 ) - if $^O =~ /(win32|vms|openbsd|bitrig|cygwin|vos)/i; + if $^O =~ /(win32|vms|openbsd|bitrig|cygwin|vos|os390)/i; # Play safe and only try this test if this system # looks pretty much Unix-like. skip( "dl_findfile test not appropriate on $^O", 1 ) diff --git a/ext/File-Glob/t/rt114984.t b/ext/File-Glob/t/rt114984.t index e53234b..43e90d7 100644 --- a/ext/File-Glob/t/rt114984.t +++ b/ext/File-Glob/t/rt114984.t @@ -32,8 +32,7 @@ foreach (@mp) { close $f; } } -my @b = glob(qq{$path/mp_[0123456789]*.dat - $path/md_[0123456789]*.dat}); +my @b = glob(qq{$path/mp_[0123456789]*.dat $path/md_[0123456789]*.dat}); if ($md+$mp < @md+@mp) { warn sprintf("$0: expected to create %d files, created only %d (path $path)\n", @md+@mp, $md+$mp); diff --git a/ext/POSIX/lib/POSIX.pm b/ext/POSIX/lib/POSIX.pm index 71b2d66..bb563bb 100644 --- a/ext/POSIX/lib/POSIX.pm +++ b/ext/POSIX/lib/POSIX.pm @@ -4,7 +4,7 @@ use warnings; our ($AUTOLOAD, %SIGRT); -our $VERSION = '1.57'; +our $VERSION = '1.58'; require XSLoader; @@ -151,7 +151,7 @@ my %reimpl = ( exit => 'status => CORE::exit($_[0])', getenv => 'name => $ENV{$_[0]}', system => 'command => CORE::system($_[0])', - strerror => 'errno => BEGIN { local $!; require locale; locale->import} local $! = $_[0]; "$!"', + strerror => 'errno => BEGIN { local $!; require locale; locale->import} my $e = $_[0] + 0; local $!; $! = $e; "$!"', strstr => 'big, little => CORE::index($_[0], $_[1])', chmod => 'mode, filename => CORE::chmod($_[0], $_[1])', fstat => 'fd => CORE::open my $dup, "<&", $_[0]; CORE::stat($dup)', # Gross. diff --git a/ext/POSIX/t/strerror_errno.t b/ext/POSIX/t/strerror_errno.t index 4807a8d..df691f1 100644 --- a/ext/POSIX/t/strerror_errno.t +++ b/ext/POSIX/t/strerror_errno.t @@ -14,4 +14,11 @@ $! = 1; POSIX::strerror(1); is (0+$!, 1, 'strerror doesn\'t destroy $!'); +# [perl #126229] POSIX::strerror() clears $! +{ + local $! = 29; + my $e = POSIX::strerror($!); + is (0+$!, 29); +} + done_testing(); diff --git a/ext/PerlIO-encoding/encoding.pm b/ext/PerlIO-encoding/encoding.pm index 4cff76d..97f05ec 100644 --- a/ext/PerlIO-encoding/encoding.pm +++ b/ext/PerlIO-encoding/encoding.pm @@ -1,7 +1,7 @@ package PerlIO::encoding; use strict; -our $VERSION = '0.21'; +our $VERSION = '0.22'; our $DEBUG = 0; $DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n"; diff --git a/ext/PerlIO-encoding/encoding.xs b/ext/PerlIO-encoding/encoding.xs index 03b8850..3575d72 100644 --- a/ext/PerlIO-encoding/encoding.xs +++ b/ext/PerlIO-encoding/encoding.xs @@ -49,13 +49,23 @@ typedef struct { #define NEEDS_LINES 1 +static const MGVTBL PerlIOEncode_tag = { 0, 0, 0, 0, 0, 0, 0, 0 }; + SV * PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) { PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); - SV *sv = &PL_sv_undef; - PERL_UNUSED_ARG(param); + SV *sv; PERL_UNUSED_ARG(flags); + /* During cloning, return an undef token object so that _pushed() knows + * that it should not call methods and wait for _dup() to actually dup the + * encoding object. */ + if (param) { + sv = newSV(0); + sv_magicext(sv, NULL, PERL_MAGIC_ext, &PerlIOEncode_tag, 0, 0); + return sv; + } + sv = &PL_sv_undef; if (e->enc) { dSP; /* Not 100% sure stack swap is right thing to do during dup ... */ @@ -85,6 +95,14 @@ PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs * IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv,tab); SV *result = Nullsv; + if (SvTYPE(arg) >= SVt_PVMG + && mg_findext(arg, PERL_MAGIC_ext, &PerlIOEncode_tag)) { + e->enc = NULL; + e->chk = NULL; + e->inEncodeCall = 0; + return code; + } + PUSHSTACKi(PERLSI_MAGIC); ENTER; SAVETMPS; @@ -566,6 +584,9 @@ PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o, if (oe->enc) { fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params); } + if (oe->chk) { + fe->chk = PerlIO_sv_dup(aTHX_ oe->chk, params); + } } return f; } diff --git a/ext/PerlIO-encoding/t/threads.t b/ext/PerlIO-encoding/t/threads.t new file mode 100644 index 0000000..64f0e55 --- /dev/null +++ b/ext/PerlIO-encoding/t/threads.t @@ -0,0 +1,35 @@ +#!perl + +use strict; +use warnings; + +BEGIN { + use Config; + if ($Config{extensions} !~ /\bEncode\b/) { + print "1..0 # Skip: no Encode\n"; + exit 0; + } + unless ($Config{useithreads}) { + print "1..0 # Skip: no threads\n"; + exit 0; + } +} + +use threads; + +use Test::More tests => 3 + 1; + +binmode *STDOUT, ':encoding(UTF-8)'; + +SKIP: { + local $@; + my $ret = eval { + my $thread = threads->create(sub { pass 'in thread'; return 1 }); + skip 'test thread could not be spawned' => 3 unless $thread; + $thread->join; + }; + is $@, '', 'thread did not croak'; + is $ret, 1, 'thread returned the right value'; +} + +pass 'passes at least one test'; diff --git a/ext/SDBM_File/sdbm.c b/ext/SDBM_File/sdbm.c index 5241fea..cf5dc75 100644 --- a/ext/SDBM_File/sdbm.c +++ b/ext/SDBM_File/sdbm.c @@ -48,6 +48,8 @@ extern Free_t free proto((Malloc_t)); } #endif +const datum nullitem = {0, 0}; + /* * forward */ diff --git a/ext/SDBM_File/sdbm.h b/ext/SDBM_File/sdbm.h index e7cf730..8d9cffd 100644 --- a/ext/SDBM_File/sdbm.h +++ b/ext/SDBM_File/sdbm.h @@ -51,11 +51,7 @@ typedef struct { int dsize; } datum; -extern const datum nullitem -#ifdef DOINIT - = {0, 0} -#endif - ; +extern const datum nullitem; #if defined(__STDC__) || defined(__cplusplus) || defined(CAN_PROTOTYPE) #define proto(p) p diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 7570d9e..14cb34e 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Carp; -our $VERSION = '0.75'; +our $VERSION = '0.76'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index ba7ecf7..b48f274 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -14,6 +14,61 @@ typedef PTR_TBL_t *XS__APItest__PtrTable; #define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__) #define croak_fail_ne(h, w) croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__) +#ifdef EBCDIC + +void +cat_utf8a2n(SV* sv, const char * const ascii_utf8, STRLEN len) +{ + /* Converts variant UTF-8 text pointed to by 'ascii_utf8' of length 'len', + * to UTF-EBCDIC, appending that text to the text already in 'sv'. + * Currently doesn't work on invariants, as that is unneeded here, and we + * could get double translations if we did. + * + * It has the algorithm for strict UTF-8 hard-coded in to find the code + * point it represents, then calls uvchr_to_utf8() to convert to + * UTF-EBCDIC). + * + * Note that this uses code points, not characters. Thus if the input is + * the UTF-8 for the code point 0xFF, the output will be the UTF-EBCDIC for + * 0xFF, even though that code point represents different characters on + * ASCII vs EBCDIC platforms. */ + + dTHX; + char * p = (char *) ascii_utf8; + const char * const e = p + len; + + while (p < e) { + UV code_point; + U8 native_utf8[UTF8_MAXBYTES + 1]; + U8 * char_end; + U8 start = (U8) *p; + + /* Start bytes are the same in both UTF-8 and I8, therefore we can + * treat this ASCII UTF-8 byte as an I8 byte. But PL_utf8skip[] is + * indexed by NATIVE_UTF8 bytes, so transform to that */ + STRLEN char_bytes_len = PL_utf8skip[I8_TO_NATIVE_UTF8(start)]; + + if (start < 0xc2) { + croak("fail: Expecting start byte, instead got 0x%X at %s line %d", + (U8) *p, __FILE__, __LINE__); + } + code_point = (start & (((char_bytes_len) >= 7) + ? 0x00 + : (0x1F >> ((char_bytes_len)-2)))); + p++; + while (p < e && ((( (U8) *p) & 0xC0) == 0x80)) { + + code_point = (code_point << 6) | (( (U8) *p) & 0x3F); + p++; + } + + char_end = uvchr_to_utf8(native_utf8, code_point); + sv_catpvn(sv, (char *) native_utf8, char_end - native_utf8); + } +} + +#endif + /* for my_cxt tests */ #define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION @@ -134,6 +189,9 @@ test_freeent(freeent_function *f) { SvREFCNT_dec(test_scalar); } +/* Not that it matters much, but it's handy for the flipped character to just + * be the opposite case (at least for ASCII-range and most Latin1 as well). */ +#define FLIP_BIT ('A' ^ 'a') static I32 bitflip_key(pTHX_ IV action, SV *field) { @@ -145,24 +203,33 @@ bitflip_key(pTHX_ IV action, SV *field) { const char *p = SvPV(keysv, len); if (len) { - SV *newkey = newSV(len); - char *new_p = SvPVX(newkey); + /* Allow for the flipped val to be longer than the original. This + * is just for testing, so can afford to have some slop */ + const STRLEN newlen = len * 2; + + SV *newkey = newSV(newlen); + const char * const new_p_orig = SvPVX(newkey); + char *new_p = (char *) new_p_orig; if (SvUTF8(keysv)) { const char *const end = p + len; while (p < end) { - STRLEN len; - UV chr = utf8_to_uvchr_buf((U8 *)p, (U8 *) end, &len); - new_p = (char *)uvchr_to_utf8((U8 *)new_p, chr ^ 32); - p += len; + STRLEN curlen; + UV chr = utf8_to_uvchr_buf((U8 *)p, (U8 *) end, &curlen); + + /* Make sure don't exceed bounds */ + assert(new_p - new_p_orig + curlen < newlen); + + new_p = (char *)uvchr_to_utf8((U8 *)new_p, chr ^ FLIP_BIT); + p += curlen; } SvUTF8_on(newkey); } else { while (len--) - *new_p++ = *p++ ^ 32; + *new_p++ = *p++ ^ FLIP_BIT; } *new_p = '\0'; - SvCUR_set(newkey, SvCUR(keysv)); + SvCUR_set(newkey, new_p - new_p_orig); SvPOK_on(newkey); mg->mg_obj = newkey; @@ -1388,6 +1455,61 @@ XS_APIVERSION_valid(...) XS_APIVERSION_BOOTCHECK; XSRETURN_EMPTY; +void +xsreturn( int len ) + PPCODE: + int i = 0; + EXTEND( SP, len ); + for ( ; i < len; i++ ) { + ST(i) = sv_2mortal( newSViv(i) ); + } + XSRETURN( len ); + +void +xsreturn_iv() + PPCODE: + XSRETURN_IV( (1<<31) + 1 ); + +void +xsreturn_uv() + PPCODE: + XSRETURN_UV( (U32)((1<<31) + 1) ); + +void +xsreturn_nv() + PPCODE: + XSRETURN_NV(0.25); + +void +xsreturn_pv() + PPCODE: + XSRETURN_PV("returned"); + +void +xsreturn_pvn() + PPCODE: + XSRETURN_PVN("returned too much",8); + +void +xsreturn_no() + PPCODE: + XSRETURN_NO; + +void +xsreturn_yes() + PPCODE: + XSRETURN_YES; + +void +xsreturn_undef() + PPCODE: + XSRETURN_UNDEF; + +void +xsreturn_empty() + PPCODE: + XSRETURN_EMPTY; + MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash void @@ -1683,7 +1805,7 @@ void test_force_keys(HV *hv) PREINIT: HE *he; - STRLEN count = 0; + SSize_t count = 0; PPCODE: hv_iterinit(hv); he = hv_iternext(hv); @@ -2082,6 +2204,39 @@ mxpushu() mXPUSHu(3); XSRETURN(3); + + # test_EXTEND(): excerise the EXTEND() macro. + # After calling EXTEND(), it also does *(p+n) = NULL and + # *PL_stack_max = NULL to allow valgrind etc to spot if the stack hasn't + # actually been extended properly. + # + # max_offset specifies the SP to use. It is treated as a signed offset + # from PL_stack_max. + # nsv is the SV holding the value of n indicating how many slots + # to extend the stack by. + # use_ss is a boolean indicating that n should be cast to a SSize_t + +void +test_EXTEND(max_offset, nsv, use_ss) + IV max_offset; + SV *nsv; + bool use_ss; +PREINIT: + SV **sp = PL_stack_max + max_offset; +PPCODE: + if (use_ss) { + SSize_t n = (SSize_t)SvIV(nsv); + EXTEND(sp, n); + *(sp + n) = NULL; + } + else { + IV n = SvIV(nsv); + EXTEND(sp, n); + *(sp + n) = NULL; + } + *PL_stack_max = NULL; + + void call_sv_C() PREINIT: @@ -2907,6 +3062,11 @@ void test_cophh() PREINIT: COPHH *a, *b; +#ifdef EBCDIC + SV* key_sv; + char * key_name; + STRLEN key_len; +#endif CODE: #define check_ph(EXPR) \ do { if((EXPR) != &PL_sv_placeholder) croak("fail"); } while(0) @@ -2970,24 +3130,81 @@ test_cophh() check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333); check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444); check_ph(cophh_fetch_pvs(a, "foo_5", 0)); - a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8); + a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8); a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0); +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8); +#else + /* On EBCDIC, we need to translate the UTF-8 in the ASCII test to the + * equivalent UTF-EBCDIC for the code page. This is done at runtime + * (with the helper function in this file). Therefore we can't use + * cophhh_store_pvs(), as we don't have literal string */ + key_sv = sv_2mortal(newSVpvs("foo_")); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8); +#endif +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8); +#endif +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8); +#endif check_iv(cophh_fetch_pvs(a, "foo_1", 0), 11111); check_iv(cophh_fetch_pvs(a, "foo_1", COPHH_KEY_UTF8), 11111); check_iv(cophh_fetch_pvs(a, "foo_\xaa", 0), 123); +#ifndef EBCDIC check_iv(cophh_fetch_pvs(a, "foo_\xc2\xaa", COPHH_KEY_UTF8), 123); check_ph(cophh_fetch_pvs(a, "foo_\xc2\xaa", 0)); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xaa")); + key_name = SvPV(key_sv, key_len); + check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 123); + check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0)); +#endif check_iv(cophh_fetch_pvs(a, "foo_\xbb", 0), 456); +#ifndef EBCDIC check_iv(cophh_fetch_pvs(a, "foo_\xc2\xbb", COPHH_KEY_UTF8), 456); check_ph(cophh_fetch_pvs(a, "foo_\xc2\xbb", 0)); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb")); + key_name = SvPV(key_sv, key_len); + check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 456); + check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0)); +#endif check_iv(cophh_fetch_pvs(a, "foo_\xcc", 0), 789); +#ifndef EBCDIC check_iv(cophh_fetch_pvs(a, "foo_\xc3\x8c", COPHH_KEY_UTF8), 789); check_ph(cophh_fetch_pvs(a, "foo_\xc2\x8c", 0)); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c")); + key_name = SvPV(key_sv, key_len); + check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 789); + check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0)); +#endif +#ifndef EBCDIC check_iv(cophh_fetch_pvs(a, "foo_\xd9\xa6", COPHH_KEY_UTF8), 666); check_ph(cophh_fetch_pvs(a, "foo_\xd9\xa6", 0)); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6")); + key_name = SvPV(key_sv, key_len); + check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 666); + check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0)); +#endif ENTER; SAVEFREECOPHH(a); LEAVE; @@ -3022,15 +3239,41 @@ HV * example_cophh_2hv() PREINIT: COPHH *a; +#ifdef EBCDIC + SV* key_sv; + char * key_name; + STRLEN key_len; +#endif CODE: #define msviv(VALUE) sv_2mortal(newSViv(VALUE)) a = cophh_new_empty(); a = cophh_store_pvs(a, "foo_0", msviv(999), 0); a = cophh_store_pvs(a, "foo_1", msviv(111), 0); a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0); +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8); +#else + key_sv = sv_2mortal(newSVpvs("foo_")); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8); +#endif +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8); +#endif +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8); +#endif a = cophh_delete_pvs(a, "foo_0", 0); a = cophh_delete_pvs(a, "foo_2", 0); RETVAL = cophh_2hv(a, 0); @@ -3375,7 +3618,7 @@ CODE: CV *cv; AV *av; SV **p; - Size_t i, size; + SSize_t i, size; cv = sv_2cv(block, &stash, &gv, 0); if (cv == Nullcv) { diff --git a/ext/XS-APItest/t/extend.t b/ext/XS-APItest/t/extend.t new file mode 100644 index 0000000..b3834b4 --- /dev/null +++ b/ext/XS-APItest/t/extend.t @@ -0,0 +1,68 @@ +#!perl +# +# Test stack expansion macros: EXTEND() etc, especially for edge cases +# where the count wraps to a native value or gets truncated. +# +# Some of these tests aren't really testing; they are however exercising +# edge cases, which other tools like ASAN may then detect problems with. +# In particular, test_EXTEND() does *(p+n) = NULL and *PL_stack_max = NULL +# before returning, to help such tools spot errors. +# +# Also, it doesn't test large but legal grow requests; only ridiculously +# large requests that are guaranteed to wrap. + +use Test::More; +use Config; +use XS::APItest qw(test_EXTEND); + +plan tests => 48; + +my $uvsize = $Config::Config{uvsize}; # sizeof(UV) +my $sizesize = $Config::Config{sizesize}; # sizeof(Size_t) + +# The first arg to test_EXTEND() is the SP to use in EXTEND(), treated +# as an offset from PL_stack_max. So extend(-1, 1, $use_ss) shouldn't +# call Perl_stack_grow(), while extend(-1, 2, $use_ss) should. +# Exercise offsets near to PL_stack_max to detect edge cases. +# Note that having the SP pointer beyond PL_stack_max is legal. + +for my $offset (-1, 0, 1) { + + # treat N as either an IV or a SSize_t + for my $use_ss (0, 1) { + + # test with N in range -1 .. 3; only the -1 should panic + + eval { test_EXTEND($offset, -1, $use_ss) }; + like $@, qr/panic: .*negative count/, "test_EXTEND($offset, -1, $use_ss)"; + + for my $n (0,1,2,3) { + eval { test_EXTEND($offset, $n, $use_ss) }; + is $@, "", "test_EXTEND($offset, $n, $use_ss)"; + } + + # some things can wrap if the int size is greater than the ptr size + + SKIP: { + skip "Not small ptrs", 3 if $use_ss || $uvsize <= $sizesize; + + # 0xffff... wraps to -1 + eval { test_EXTEND($offset, (1 << 8*$sizesize)-1, $use_ss) }; + like $@, qr/panic: .*negative count/, + "test_EXTEND(-1, SIZE_MAX, $use_ss)"; + + # 0x10000... truncates to zero; + # but the wrap-detection code converts it to -1 to force a panic + eval { test_EXTEND($offset, 1 << 8*$sizesize, $use_ss) }; + like $@, qr/panic: .*negative count/, + "test_EXTEND(-1, SIZE_MAX+1, $use_ss)"; + + # 0x1ffff... truncates and then wraps to -1 + eval { test_EXTEND($offset, (1 << (8*$sizesize+1))-1, $use_ss) }; + like $@, qr/panic: .*negative count/, + "test_EXTEND(-1, 2*SIZE_MAX-1, $use_ss)"; + + + } + } +} diff --git a/ext/XS-APItest/t/hash.t b/ext/XS-APItest/t/hash.t index ac8eebe..77a23aa 100644 --- a/ext/XS-APItest/t/hash.t +++ b/ext/XS-APItest/t/hash.t @@ -102,11 +102,21 @@ foreach my $in ("", "N", "a\0b") { foreach my $upgrade_n (0, 1) { my (%hash, %placebo); XS::APItest::Hash::bitflip_hash(\%hash); - foreach my $new (["7", 65, 67, 80], - ["8", 163, 171, 215], + foreach my $new (["7", utf8::unicode_to_native(65), + utf8::unicode_to_native(67), + utf8::unicode_to_native(80) + ], + ["8", utf8::unicode_to_native(163), + utf8::unicode_to_native(171), + utf8::unicode_to_native(215) + ], ["U", 2603, 2604, 2604], - ) { - foreach my $code (78, 240, 256, 1336) { + ) { + foreach my $code (utf8::unicode_to_native(78), + utf8::unicode_to_native(240), + 256, + 1336 + ) { my $key = chr $code; # This is the UTF-8 byte sequence for the key. my $key_utf8 = $key; @@ -571,6 +581,7 @@ sub rot13 { } sub bitflip { - my @results = map {join '', map {chr(32 ^ ord $_)} split '', $_} @_; + my $flip_bit = ord("A") ^ ord("a"); + my @results = map {join '', map {chr($flip_bit ^ ord $_)} split '', $_} @_; wantarray ? @results : $results[0]; } diff --git a/ext/XS-APItest/t/newDEFSVOP.t b/ext/XS-APItest/t/newDEFSVOP.t index 1ba6ee6..42d45b2 100644 --- a/ext/XS-APItest/t/newDEFSVOP.t +++ b/ext/XS-APItest/t/newDEFSVOP.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 16; +use Test::More tests => 7; use XS::APItest qw(DEFSV); @@ -18,23 +18,3 @@ is $_, "foo"; $_ = "bar"; is DEFSV, "bar"; is $_, "bar"; - -{ - no warnings 'experimental::lexical_topic'; - my $_; - - is $_, undef; - is DEFSV, undef; - is \DEFSV, \$_; - - DEFSV = "lex-foo"; - is DEFSV, "lex-foo"; - is $_, "lex-foo"; - - $_ = "lex-bar"; - is DEFSV, "lex-bar"; - is $_, "lex-bar"; -} - -is DEFSV, "bar"; -is $_, "bar"; diff --git a/ext/XS-APItest/t/underscore_length.t b/ext/XS-APItest/t/underscore_length.t index 545b2a3..580f9f9 100644 --- a/ext/XS-APItest/t/underscore_length.t +++ b/ext/XS-APItest/t/underscore_length.t @@ -1,7 +1,7 @@ -use warnings; no warnings 'experimental::lexical_topic'; +use warnings; use strict; -use Test::More tests => 4; +use Test::More tests => 2; use XS::APItest qw(underscore_length); @@ -11,10 +11,4 @@ is underscore_length(), 3; $_ = "snowman \x{2603}"; is underscore_length(), 9; -my $_ = "xyzzy"; -is underscore_length(), 5; - -$_ = "pile of poo \x{1f4a9}"; -is underscore_length(), 13; - 1; diff --git a/ext/XS-APItest/t/xsub_h.t b/ext/XS-APItest/t/xsub_h.t index 9bf0710..e763130 100644 --- a/ext/XS-APItest/t/xsub_h.t +++ b/ext/XS-APItest/t/xsub_h.t @@ -120,4 +120,35 @@ is(eval {XS_APIVERSION_invalid("Pie"); 1}, undef, like($@, qr/Perl API version v1.0.16 of Pie does not match v5\.\d+\.\d+/, "expected error"); +my @xsreturn; +@xsreturn = XS::APItest::XSUB::xsreturn(2); +is scalar @xsreturn, 2, 'returns a list of 2 elements'; +is $xsreturn[0], 0; +is $xsreturn[1], 1; + +my $xsreturn = XS::APItest::XSUB::xsreturn(3); +is $xsreturn, 2, 'returns the last item on the stack'; + +( $xsreturn ) = XS::APItest::XSUB::xsreturn(3); +is $xsreturn, 0, 'gets the first item on the stack'; + +is XS::APItest::XSUB::xsreturn_iv(), -2**31+1, 'XSRETURN_IV returns signed int'; +is XS::APItest::XSUB::xsreturn_uv(), 2**31+1, 'XSRETURN_UV returns unsigned int'; +is XS::APItest::XSUB::xsreturn_nv(), 0.25, 'XSRETURN_NV returns double'; +is XS::APItest::XSUB::xsreturn_pv(), "returned", 'XSRETURN_PV returns string'; +is XS::APItest::XSUB::xsreturn_pvn(), "returned", 'XSRETURN_PVN returns string with length'; +ok !XS::APItest::XSUB::xsreturn_no(), 'XSRETURN_NO returns falsey'; +ok XS::APItest::XSUB::xsreturn_yes(), 'XSRETURN_YES returns truthy'; + +is XS::APItest::XSUB::xsreturn_undef(), undef, 'XSRETURN_UNDEF returns undef in scalar context'; +my @xs_undef = XS::APItest::XSUB::xsreturn_undef(); +is scalar @xs_undef, 1, 'XSRETURN_UNDEF returns a single-element list'; +is $xs_undef[0], undef, 'XSRETURN_UNDEF returns undef in list context'; + +my @xs_empty = XS::APItest::XSUB::xsreturn_empty(); +is scalar @xs_empty, 0, 'XSRETURN_EMPTY returns empty list in array context'; +my $xs_empty = XS::APItest::XSUB::xsreturn_empty(); +is $xs_empty, undef, 'XSRETURN_EMPTY returns undef in scalar context'; + + done_testing(); diff --git a/ext/arybase/t/akeys.t b/ext/arybase/t/akeys.t index dc490c4..a76fade 100644 --- a/ext/arybase/t/akeys.t +++ b/ext/arybase/t/akeys.t @@ -1,4 +1,4 @@ -use warnings; no warnings 'deprecated', 'experimental::lexical_topic'; +use warnings; no warnings 'deprecated'; use strict; BEGIN { @@ -8,7 +8,7 @@ BEGIN { } } -use Test::More tests => 8; +use Test::More tests => 4; our @t; @@ -22,19 +22,4 @@ is_deeply [ keys @t ], []; is_deeply [ scalar keys @t ], [ 6 ]; is_deeply [ keys @t ], [ 3, 4, 5, 6, 7, 8 ]; -SKIP: { - skip "no lexical \$_", 4 unless eval q{my $_; 1}; - eval q{ - my $_; - - @t = (); - is_deeply [ scalar keys @t ], [ 0 ]; - is_deeply [ keys @t ], []; - - @t = qw(a b c d e f); - is_deeply [ scalar keys @t ], [ 6 ]; - is_deeply [ keys @t ], [ 3, 4, 5, 6, 7, 8 ]; - }; -} - 1; diff --git a/ext/arybase/t/aslice.t b/ext/arybase/t/aslice.t index 462ee3d..20782e5 100644 --- a/ext/arybase/t/aslice.t +++ b/ext/arybase/t/aslice.t @@ -1,7 +1,7 @@ -use warnings; no warnings 'deprecated', 'experimental::lexical_topic'; +use warnings; no warnings 'deprecated'; use strict; -use Test::More tests => 18; +use Test::More tests => 10; our @t = qw(a b c d e f); our $r = \@t; @@ -24,19 +24,4 @@ is_deeply [ @t[2,-1,1,-2] ], [ qw(f f e e) ]; is_deeply [@t[-3,()]], ['a']; } -SKIP: { - skip "no lexical \$_", 8 unless eval q{my $_; 1}; - eval q{ - my $_; - is_deeply [ scalar @t[3,4] ], [ qw(b) ]; - is_deeply [ @t[3,4,8,9] ], [ qw(a b f), undef ]; - is_deeply [ scalar @t[@i4] ], [ qw(c) ]; - is_deeply [ @t[@i4] ], [ qw(a c a c) ]; - is_deeply [ scalar @{$r}[3,4] ], [ qw(b) ]; - is_deeply [ @{$r}[3,4,8,9] ], [ qw(a b f), undef ]; - is_deeply [ scalar @{$r}[@i4] ], [ qw(c) ]; - is_deeply [ @{$r}[@i4] ], [ qw(a c a c) ]; - }; -} - 1; diff --git a/ext/arybase/t/lslice.t b/ext/arybase/t/lslice.t index 828ea3e..08aabe9 100644 --- a/ext/arybase/t/lslice.t +++ b/ext/arybase/t/lslice.t @@ -1,7 +1,7 @@ -use warnings; no warnings 'deprecated', 'experimental::lexical_topic'; +use warnings; no warnings 'deprecated'; use strict; -use Test::More tests => 12; +use Test::More tests => 8; our @i4 = (3, 5, 3, 5); @@ -20,15 +20,4 @@ is_deeply [ qw(a b c d e f)[2,1] ], [ qw(f e) ]; is_deeply [qw(a b c d e f)[-3]], ['a']; } -SKIP: { - skip "no lexical \$_", 4 unless eval q{my $_; 1}; - eval q{ - my $_; - is_deeply [ scalar qw(a b c d e f)[3,4] ], [ qw(b) ]; - is_deeply [ qw(a b c d e f)[3,4,8,9] ], [ qw(a b f), undef ]; - is_deeply [ scalar qw(a b c d e f)[@i4] ], [ qw(c) ]; - is_deeply [ qw(a b c d e f)[@i4] ], [ qw(a c a c) ]; - }; -} - 1; diff --git a/gv.c b/gv.c index e82f18d..0283b2d 100644 --- a/gv.c +++ b/gv.c @@ -1975,6 +1975,10 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, case '\027': /* $^WARNING_BITS */ if (strEQ(name2, "ARNING_BITS")) goto magicalize; +#ifdef WIN32 + else if (strEQ(name2, "IN32_SLOPPY_STAT")) + goto magicalize; +#endif break; case '1': case '2': diff --git a/handy.h b/handy.h index 0318504..79e9cfd 100644 --- a/handy.h +++ b/handy.h @@ -280,8 +280,13 @@ typedef U64TYPE U64; /* This is a helper macro to avoid preprocessor issues, replaced by nothing * unless under DEBUGGING, where it expands to an assert of its argument, * followed by a comma (hence the comma operator). If we just used a straight - * assert(), we would get a comma with nothing before it when not DEBUGGING */ -#ifdef DEBUGGING + * assert(), we would get a comma with nothing before it when not DEBUGGING. + * + * We also use empty definition under Coverity since the __ASSERT__ + * checks often check for things that Really Cannot Happen, and Coverity + * detects that and gets all excited. */ + +#if defined(DEBUGGING) && !defined(__COVERITY__) # define __ASSERT_(statement) assert(statement), #else # define __ASSERT_(statement) @@ -1917,10 +1922,13 @@ PoisonWith(0xEF) for catching access to freed memory. * As well as avoiding the need for a run-time check in some cases, it's * designed to avoid compiler warnings like: * comparison is always false due to limited range of data type + * It's mathematically equivalent to + * max(n) * sizeof(t) > MEM_SIZE_MAX */ # define _MEM_WRAP_NEEDS_RUNTIME_CHECK(n,t) \ - (sizeof(t) > ((MEM_SIZE)1 << 8*(sizeof(MEM_SIZE) - sizeof(n)))) + ( sizeof(MEM_SIZE) < sizeof(n) \ + || sizeof(t) > ((MEM_SIZE)1 << 8*(sizeof(MEM_SIZE) - sizeof(n)))) /* This is written in a slightly odd way to avoid various spurious * compiler warnings. We *want* to write the expression as diff --git a/hints/catamount.sh b/hints/catamount.sh index 58dfc9f..f95eabc 100644 --- a/hints/catamount.sh +++ b/hints/catamount.sh @@ -31,11 +31,11 @@ # mkdir -p /opt/perl-catamount # mkdir -p /opt/perl-catamount/include # mkdir -p /opt/perl-catamount/lib -# mkdir -p /opt/perl-catamount/lib/perl5/5.23.3 +# mkdir -p /opt/perl-catamount/lib/perl5/5.23.4 # mkdir -p /opt/perl-catamount/bin # cp *.h /opt/perl-catamount/include # cp libperl.a /opt/perl-catamount/lib -# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.23.3 +# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.23.4 # cp miniperl perl run.sh cc.sh /opt/perl-catamount/lib # # With the headers and the libperl.a you can embed Perl to your Catamount diff --git a/hints/darwin.sh b/hints/darwin.sh index 81cdcff..fa55b44 100644 --- a/hints/darwin.sh +++ b/hints/darwin.sh @@ -186,30 +186,132 @@ case "$ld" in ;; esac +# From http://ftp.netbsd.org/pub/pkgsrc/current/pkgsrc/mk/platform/Darwin.mk +# +# OS, Kernel, Xcode Version +# Note that Xcode gets updates on older systems sometimes. +# pkgsrc generally expects that the most up-to-date xcode available for +# an OS version is installed +# +# Codename OS Kernel Xcode +# Cheetah 10.0.x 1.3.1 +# Puma 10.1 1.4.1 +# 10.1.x 5.x.y +# Jaguar 10.2.x 6.x.y +# Panther 10.3.x 7.x.y +# Tiger 10.4.x 8.x.y 2.x (gcc 4.0, 4.0.1 from 2.2) +# Leopard 10.5.x 9.x.y 3.x (gcc 4.0.1, 4.0.1 and 4.2.1 from 3.1) +# Snow Leopard 10.6.x 10.x.y 3.2+ (gcc 4.0.1 and 4.2.1) +# Lion 10.7.x 11.x.y 4.1 (llvm gcc 4.2.1) +# Mountain Lion 10.8.x 12.x.y 4.5 (llvm gcc 4.2.1) +# Mavericks 10.9.x 13.x.y 6 (llvm clang 6.0) +# Yosemite 10.10.x 14.x.y 6 (llvm clang 6.0) +# El Capitan 10.11.x 15.x.y 7 (llvm clang 7.0) + +# Processors Supported +# +# PowerPC (PPC): 10.0.x - 10.5.8 (final 10.5.x) +# PowerPC via Rosetta: 10.4.4 - 10.6.8 (final 10.6.x) +# IA-32: 10.4.4 - 10.6.8 (though still supported on x86-64) +# x86-64: 10.4.7 - current + +# MACOSX_DEPLOYMENT_TARGET selects the minimum OS level we want to support +# +# It is needed for OS releases before 10.6. +# +# https://developer.apple.com/library/mac/documentation/DeveloperTools/Conceptual/cross_development/Configuring/configuring.html +# +# If it is set, we also propagate its value to ccflags and ldflags +# using the -mmacosx-version-min flag. If it is not set, we use +# the OS X release as the min value for the flag. + +# Adds "-mmacosx-version-min=$2" to "$1" unless it already is there. +add_macosx_version_min () { + local v + eval "v=\$$1" + case " $v " in + *"-mmacosx-version-min"*) + echo "NOT adding -mmacosx-version-min=$2 to $1 ($v)" >&4 + ;; + *) echo "Adding -mmacosx-version-min=$2 to $1" >&4 + eval "$1='$v -mmacosx-version-min=$2'" + ;; + esac +} + # Perl bundles do not expect two-level namespace, added in Darwin 1.4. # But starting from perl 5.8.1/Darwin 7 the default is the two-level. -case "$osvers" in -1.[0-3].*) +case "$osvers" in # Note: osvers is the kernel version, not the 10.x +1.[0-3].*) # OS X 10.0.x lddlflags="${ldflags} -bundle -undefined suppress" ;; -1.*) +1.*) # OS X 10.1 ldflags="${ldflags} -flat_namespace" lddlflags="${ldflags} -bundle -undefined suppress" ;; -[2-6].*) +[2-6].*) # OS X 10.1.x - 10.2.x (though [2-4] never existed publicly) ldflags="${ldflags} -flat_namespace" lddlflags="${ldflags} -bundle -undefined suppress" ;; -*) - # MACOSX_DEPLOYMENT_TARGET selects the minimum OS level we want to support - # https://developer.apple.com/library/mac/documentation/DeveloperTools/Conceptual/cross_development/Configuring/configuring.html +[7-9].*) # OS X 10.3.x - 10.5.x lddlflags="${ldflags} -bundle -undefined dynamic_lookup" case "$ld" in *MACOSX_DEVELOPMENT_TARGET*) ;; *) ld="env MACOSX_DEPLOYMENT_TARGET=10.3 ${ld}" ;; esac ;; +*) # OS X 10.6.x - current + # The MACOSX_DEPLOYMENT_TARGET is not needed, + # but the -mmacosx-version-min option is always used. + + # We now use MACOSX_DEPLOYMENT_TARGET, if set, as an override by + # capturing its value and adding it to the flags. + case "$MACOSX_DEPLOYMENT_TARGET" in + 10.*) + add_macosx_version_min ccflags $MACOSX_DEPLOYMENT_TARGET + add_macosx_version_min ldflags $MACOSX_DEPLOYMENT_TARGET + ;; + '') + # Empty MACOSX_DEPLOYMENT_TARGET is okay. + ;; + *) + cat <&4 + +*** Unexpected MACOSX_DEPLOYMENT_TARGET=$MACOSX_DEPLOYMENT_TARGET +*** +*** Please either set it to 10.something, or to empty. + +EOM + exit 1 + ;; + esac + + # Keep the prodvers leading whitespace (Configure magic). + # Cannot use $osvers here since that is the kernel version. + # sw_vers output what we want + # "ProductVersion: 10.10.5" "10.10" + # "ProductVersion: 10.11" "10.11" + prodvers=`sw_vers|awk '/^ProductVersion:/{print $2}'|awk -F. '{print $1"."$2}'` + case "$prodvers" in + 10.*) + add_macosx_version_min ccflags $prodvers + add_macosx_version_min ldflags $prodvers + ;; + *) + cat <&4 + +*** Unexpected product version $prodvers. +*** +*** Try running sw_vers and see what its ProductVersion says. + +EOM + exit 1 + esac + + lddlflags="${ldflags} -bundle -undefined dynamic_lookup" + ;; esac + ldlibpthname='DYLD_LIBRARY_PATH'; # useshrplib=true results in much slower startup times. diff --git a/hints/irix_6.sh b/hints/irix_6.sh index fc315a5..832fde2 100644 --- a/hints/irix_6.sh +++ b/hints/irix_6.sh @@ -683,3 +683,6 @@ usemymalloc=${usemymalloc:-false} # instead; in IRIX this is not true because the prototype of fcntl() # requires explicit include of i_fcntl=define + +# There is but it's not the Linux one that Configure expects. +d_prctl="$undef" diff --git a/hints/linux-android.sh b/hints/linux-android.sh index 6a59cb7..51fd5f5 100644 --- a/hints/linux-android.sh +++ b/hints/linux-android.sh @@ -80,18 +80,6 @@ if test "X$android_warn" != X; then fi $cat > try.c << 'EOM' -#include -#include -#include -int main() { (void) getmntent(stdout); return(0); } -EOM -$cc $ccflags try.c -o try -android_warn=`$run ./try 2>&1 | $egrep "$android_stub"` -if test "X$android_warn" != X; then - d_getmntent="$undef" -fi - -$cat > try.c << 'EOM' #include int main() { (void) getprotobyname("foo"); return(0); } EOM diff --git a/hv.c b/hv.c index 253cad9..3bab3e2 100644 --- a/hv.c +++ b/hv.c @@ -1599,8 +1599,8 @@ Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry) Frees the all the elements of a hash, leaving it empty. The XS equivalent of C<%hash = ()>. See also L. -If any destructors are triggered as a result, the hv itself may -be freed. +See L for a note about the hash possibly being invalid on +return. =cut */ @@ -1834,10 +1834,8 @@ Undefines the hash. The XS equivalent of C. As well as freeing all the elements of the hash (like C), this also frees any auxiliary data and storage associated with the hash. -If any destructors are triggered as a result, the hv itself may -be freed. - -See also L. +See L for a note about the hash possibly being invalid on +return. =cut */ diff --git a/hv_func.h b/hv_func.h index b0e50e3..8866db9 100644 --- a/hv_func.h +++ b/hv_func.h @@ -83,9 +83,11 @@ # if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) # define PERL_HASH_SEED PL_hash_seed # elif PERL_HASH_SEED_BYTES == 4 -# define PERL_HASH_SEED "PeRl" +# define PERL_HASH_SEED ((const U8 *)"PeRl") +# elif PERL_HASH_SEED_BYTES == 8 +# define PERL_HASH_SEED ((const U8 *)"PeRlHaSh") # elif PERL_HASH_SEED_BYTES == 16 -# define PERL_HASH_SEED "PeRlHaShhAcKpErl" +# define PERL_HASH_SEED ((const U8 *)"PeRlHaShhAcKpErl") # else # error "No PERL_HASH_SEED definition for " PERL_HASH_FUNC # endif diff --git a/intrpvar.h b/intrpvar.h index 9d51290..7dc4be4 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -76,7 +76,22 @@ PERLVAR(I, curpm, PMOP *) /* what to do \ interps in REs from */ PERLVAR(I, tainting, bool) /* doing taint checks */ PERLVAR(I, tainted, bool) /* using variables controlled by $< */ + +/* PL_delaymagic is currently used for two purposes: to assure simultaneous + * updates in ($<,$>) = ..., and to assure atomic update in push/unshift + * @ISA, It works like this: a few places such as pp_push set the DM_DELAY + * flag; then various places such as av_store() skip mg_set(ary) if this + * flag is set, and various magic vtable methods set flags like + * DM_ARRAY_ISA if they've seen something of that ilk. Finally when + * control returns to pp_push or whatever, it sees if any of those flags + * have been set, and if so finally calls mg_set(). + * + * NB: PL_delaymagic is automatically saved and restored by JUMPENV_PUSH + * / POP. This removes the need to do ENTER/SAVEI16(PL_delaymagic)/LEAVE + * in hot code like pp_push. + */ PERLVAR(I, delaymagic, U16) /* ($<,$>) = ... */ + PERLVAR(I, localizing, U8) /* are we processing a local() list? */ PERLVAR(I, in_eval, U8) /* trap "fatal" errors? */ PERLVAR(I, defgv, GV *) /* the *_ glob */ @@ -176,7 +191,7 @@ PERLVAR(I, statgv, GV *) PERLVARI(I, statname, SV *, NULL) #ifdef HAS_TIMES -/* Will be removed soon after v5.23.3. See RT #121351 */ +/* Will be removed soon after v5.23.4. See RT #121351 */ PERLVAR(I, timesbuf, struct tms) #endif @@ -751,7 +766,7 @@ PERLVARI(I, globhook, globhook_t, NULL) PERLVARI(I, padlist_generation, U32, 1) /* id to identify padlist clones */ -/* The last unconditional member of the interpreter structure when 5.23.3 was +/* The last unconditional member of the interpreter structure when 5.23.4 was released. The offset of the end of this is baked into a global variable in any shared perl library which will allow a sanity test in future perl releases. */ diff --git a/iperlsys.h b/iperlsys.h index 3aee24f..86ab687 100644 --- a/iperlsys.h +++ b/iperlsys.h @@ -478,7 +478,7 @@ typedef char* (*LPENVGetenv_len)(struct IPerlEnv*, #endif #ifdef WIN32 typedef unsigned long (*LPEnvOsID)(struct IPerlEnv*); -typedef char* (*LPEnvLibPath)(struct IPerlEnv*, const char*, +typedef char* (*LPEnvLibPath)(struct IPerlEnv*, WIN32_NO_REGISTRY_M_(const char*) STRLEN *const len); typedef char* (*LPEnvSiteLibPath)(struct IPerlEnv*, const char*, STRLEN *const len); @@ -550,7 +550,7 @@ struct IPerlEnvInfo #define PerlEnv_os_id() \ (*PL_Env->pEnvOsID)(PL_Env) #define PerlEnv_lib_path(str, lenp) \ - (*PL_Env->pLibPath)(PL_Env,(str),(lenp)) + (*PL_Env->pLibPath)(PL_Env,WIN32_NO_REGISTRY_M_(str)(lenp)) #define PerlEnv_sitelib_path(str, lenp) \ (*PL_Env->pSiteLibPath)(PL_Env,(str),(lenp)) #define PerlEnv_vendorlib_path(str, lenp) \ @@ -575,7 +575,7 @@ struct IPerlEnvInfo #ifdef WIN32 #define PerlEnv_os_id() win32_os_id() -#define PerlEnv_lib_path(str, lenp) win32_get_privlib(str, lenp) +#define PerlEnv_lib_path(str, lenp) win32_get_privlib(WIN32_NO_REGISTRY_M_(str) lenp) #define PerlEnv_sitelib_path(str, lenp) win32_get_sitelib(str, lenp) #define PerlEnv_vendorlib_path(str, lenp) win32_get_vendorlib(str, lenp) #define PerlEnv_get_child_IO(ptr) win32_get_child_IO(ptr) diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t index b4874a4..62c0a4b 100644 --- a/lib/B/Deparse.t +++ b/lib/B/Deparse.t @@ -1872,12 +1872,12 @@ my sub f {} print f(); >>>> use feature 'lexical_subs'; -BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x55"} +BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x15"} my sub f { - BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"} + BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x15"} } -BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"} +BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x15"} print f(); #### # SKIP ?$] < 5.017004 && "lexical subs not implemented on this Perl version" @@ -1888,13 +1888,13 @@ state sub f {} print f(); >>>> use feature 'lexical_subs'; -BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x55"} +BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55\x15"} CORE::state sub f { - BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"} + BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x15"} use feature 'state'; } -BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x55"} +BEGIN {${^WARNING_BITS} = "\x54\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x54\x55\x55\x15"} use feature 'state'; print f(); #### diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm index 54607bb..44cda8e 100644 --- a/lib/B/Op_private.pm +++ b/lib/B/Op_private.pm @@ -118,7 +118,7 @@ package B::Op_private; our %bits; -our $VERSION = "5.023003"; +our $VERSION = "5.023004"; $bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv); $bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv); @@ -128,7 +128,6 @@ $bits{$_}{1} = 'OPpFT_ACCESS' for qw(fteexec fteread ftewrite ftrexec ftrread ft $bits{$_}{4} = 'OPpFT_AFTER_t' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero); $bits{$_}{2} = 'OPpFT_STACKED' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero); $bits{$_}{3} = 'OPpFT_STACKING' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero); -$bits{$_}{1} = 'OPpGREP_LEX' for qw(grepstart grepwhile mapstart mapwhile); $bits{$_}{1} = 'OPpHINT_STRICT_REFS' for qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv); $bits{$_}{5} = 'OPpHUSH_VMSISH' for qw(dbstate nextstate); $bits{$_}{2} = 'OPpITER_REVERSED' for qw(enteriter iter); @@ -150,7 +149,7 @@ $bits{$_}{7} = 'OPpPV_IS_UTF8' for qw(dump goto last next redo); $bits{$_}{6} = 'OPpREFCOUNTED' for qw(leave leaveeval leavesub leavesublv leavewrite); $bits{$_}{6} = 'OPpRUNTIME' for qw(match pushre qr subst substcont); $bits{$_}{2} = 'OPpSLICEWARNING' for qw(aslice hslice padav padhv rv2av rv2hv); -$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log match mkdir modulo multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push pushre qr rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subst subtract symlink system time trans transr unlink unshift utime wait waitpid); +$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log mkdir modulo multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid); $bits{$_}{5} = 'OPpTRANS_COMPLEMENT' for qw(trans transr); $bits{$_}{7} = 'OPpTRANS_DELETE' for qw(trans transr); $bits{$_}{0} = 'OPpTRANS_FROM_UTF' for qw(trans transr); @@ -602,7 +601,6 @@ our %defines = ( OPpFT_AFTER_t => 16, OPpFT_STACKED => 4, OPpFT_STACKING => 8, - OPpGREP_LEX => 2, OPpHINT_STRICT_REFS => 2, OPpHUSH_VMSISH => 32, OPpITER_DEF => 8, @@ -696,7 +694,6 @@ our %labels = ( OPpFT_AFTER_t => 'FTAFTERt', OPpFT_STACKED => 'FTSTACKED', OPpFT_STACKING => 'FTSTACKING', - OPpGREP_LEX => 'GREPLEX', OPpHINT_STRICT_REFS => 'STRICT', OPpHUSH_VMSISH => 'HUSH', OPpITER_DEF => 'DEF', @@ -766,7 +763,6 @@ our %ops_using = ( OPpFLIP_LINENUM => [qw(flip flop)], OPpFT_ACCESS => [qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite)], OPpFT_AFTER_t => [qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero)], - OPpGREP_LEX => [qw(grepstart grepwhile mapstart mapwhile)], OPpHINT_STRICT_REFS => [qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv)], OPpHUSH_VMSISH => [qw(dbstate nextstate)], OPpITER_DEF => [qw(enteriter)], @@ -793,7 +789,7 @@ our %ops_using = ( OPpSORT_DESCEND => [qw(sort)], OPpSPLIT_IMPLIM => [qw(split)], OPpSUBSTR_REPL_FIRST => [qw(substr)], - OPpTARGET_MY => [qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log match mkdir modulo multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push pushre qr rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subst subtract symlink system time trans transr unlink unshift utime wait waitpid)], + OPpTARGET_MY => [qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log mkdir modulo multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid)], OPpTRANS_COMPLEMENT => [qw(trans transr)], ); diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index 5f61527..1cdb846 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -378,7 +378,11 @@ T_PACKEDARRAY T_ARRAY { U32 ix_$var; - EXTEND(SP,size_$var); + SSize_t extend_size = + sizeof(size_$var) > sizeof(SSize_t) && size_$var > SSize_t_MAX + ? -1 /* might wrap; -1 triggers a panic in EXTEND() */ + : (SSize_t)size_$var; + EXTEND(SP, extend_size); for (ix_$var = 0; ix_$var < size_$var; ix_$var++) { ST(ix_$var) = sv_newmortal(); DO_ARRAY_ELEM diff --git a/lib/unicore/mktables b/lib/unicore/mktables index 449e411..ffdb849 100644 --- a/lib/unicore/mktables +++ b/lib/unicore/mktables @@ -19546,16 +19546,19 @@ eval { require "./loc_tools.pl" }; $utf8_locale = &find_utf8_ctype_locale if defined &find_utf8_ctype_locale; sub _test_break($$) { - # Test qr/\X/ matches. The input is a line from auxiliary/GCBTest.txt - # Each such line is a sequence of code points given by their hex numbers, - # separated by the two characters defined just before this subroutine that - # indicate that either there can or cannot be a break between the adjacent - # code points. If there isn't a break, that means the sequence forms an - # extended grapheme cluster, which means that \X should match the whole - # thing. If there is a break, \X should stop there. This is all - # converted by this routine into a match: - # $string =~ /(\X)/, - # Each \X should match the next cluster; and that is what is checked. + # Test various break property matches. The 2nd parameter gives the + # property name. The input is a line from auxiliary/*Test.txt for the + # given property. Each such line is a sequence of code points given by + # their hex numbers, separated by the two characters defined just before + # this subroutine that indicate that either there can or cannot be a break + # between the adjacent code points. All these are tested. + # + # For the gcb property extra tests are made. if there isn't a break, that + # means the sequence forms an extended grapheme cluster, which means that + # \X should match the whole thing. If there is a break, \X should stop + # there. This is all converted by this routine into a match: $string =~ + # /(\X)/, Each \X should match the next cluster; and that is what is + # checked. my $template = shift; my $break_type = shift; @@ -19659,6 +19662,7 @@ sub _test_break($$) { my $B_pattern = "$1$2"; $matched = $string =~ qr/$B_pattern/; print "not " unless $matched; + $matched = ($matched) ? "matched" : "failed to match"; print "ok ", ++$Tests, " - \"$display_string\" $matched /$B_pattern/$display_upgrade; line $line $display_locale\n"; } } diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl index 51137b5..0d2e662 100644 --- a/lib/utf8_heavy.pl +++ b/lib/utf8_heavy.pl @@ -289,8 +289,8 @@ sub _loose_name ($) { if ($parts[1] =~ s/^-//) { # If numerator is also negative, convert the - # whole thing to positive, or move the minus to - # the numerator + # whole thing to positive, else move the minus + # to the numerator if ($parts[0] !~ s/^-//) { $parts[0] = '-' . $parts[0]; } diff --git a/lib/warnings.pm b/lib/warnings.pm index 332f7c1..8d94724 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -5,7 +5,7 @@ package warnings; -our $VERSION = '1.33'; +our $VERSION = "1.35"; # Verify that we're called correctly so that warnings will work. # see also strict.pm. @@ -75,28 +75,27 @@ our %Offsets = ( # Warnings Categories added in Perl 5.017 'experimental' => 102, 'experimental::lexical_subs' => 104, - 'experimental::lexical_topic' => 106, - 'experimental::regex_sets' => 108, - 'experimental::smartmatch' => 110, + 'experimental::regex_sets' => 106, + 'experimental::smartmatch' => 108, # Warnings Categories added in Perl 5.019 - 'experimental::postderef' => 112, - 'experimental::signatures' => 114, - 'syscalls' => 116, + 'experimental::postderef' => 110, + 'experimental::signatures' => 112, + 'syscalls' => 114, # Warnings Categories added in Perl 5.021 - 'experimental::bitwise' => 118, - 'experimental::const_attr' => 120, - 'experimental::re_strict' => 122, - 'experimental::refaliasing' => 124, - 'experimental::win32_perlio' => 126, - 'locale' => 128, - 'missing' => 130, - 'redundant' => 132, + 'experimental::bitwise' => 116, + 'experimental::const_attr' => 118, + 'experimental::re_strict' => 120, + 'experimental::refaliasing' => 122, + 'experimental::win32_perlio' => 124, + 'locale' => 126, + 'missing' => 128, + 'redundant' => 130, ); our %Bits = ( - 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..66] + 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x05", # [0..65] 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [29] 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [30] 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] @@ -106,29 +105,28 @@ our %Bits = ( 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31] 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] - 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x45\x55\x00", # [51..57,59..63] - 'experimental::bitwise' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [59] - 'experimental::const_attr' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [60] + 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x51\x15\x00", # [51..56,58..62] + 'experimental::bitwise' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [58] + 'experimental::const_attr' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [59] 'experimental::lexical_subs' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [52] - 'experimental::lexical_topic' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [53] - 'experimental::postderef' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [56] - 'experimental::re_strict' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [61] - 'experimental::refaliasing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [62] - 'experimental::regex_sets' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [54] - 'experimental::signatures' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [57] - 'experimental::smartmatch' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [55] - 'experimental::win32_perlio' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [63] + 'experimental::postderef' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [55] + 'experimental::re_strict' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [60] + 'experimental::refaliasing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [61] + 'experimental::regex_sets' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [53] + 'experimental::signatures' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [56] + 'experimental::smartmatch' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [54] + 'experimental::win32_perlio' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [62] 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [47] 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [46] 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23] 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24] - 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [5..11,58] + 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [5..11,57] 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] - 'locale' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [64] + 'locale' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [63] 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25] 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12] - 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [65] + 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [64] 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [48] 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [49] @@ -145,7 +143,7 @@ our %Bits = ( 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [36] 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18] 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19] - 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [66] + 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [65] 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20] 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [37] 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [38] @@ -154,7 +152,7 @@ our %Bits = ( 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27] 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [50] 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00\x00\x00\x00", # [28..38,47] - 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [58] + 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [57] 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [39] 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [40] 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [41] @@ -166,7 +164,7 @@ our %Bits = ( ); our %DeadBits = ( - 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..66] + 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x0a", # [0..65] 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [29] 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [30] 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] @@ -176,29 +174,28 @@ our %DeadBits = ( 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31] 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] - 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\x8a\xaa\x00", # [51..57,59..63] - 'experimental::bitwise' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [59] - 'experimental::const_attr' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [60] + 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\xa2\x2a\x00", # [51..56,58..62] + 'experimental::bitwise' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [58] + 'experimental::const_attr' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [59] 'experimental::lexical_subs' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [52] - 'experimental::lexical_topic' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [53] - 'experimental::postderef' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [56] - 'experimental::re_strict' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [61] - 'experimental::refaliasing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [62] - 'experimental::regex_sets' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [54] - 'experimental::signatures' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [57] - 'experimental::smartmatch' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [55] - 'experimental::win32_perlio' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [63] + 'experimental::postderef' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [55] + 'experimental::re_strict' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [60] + 'experimental::refaliasing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [61] + 'experimental::regex_sets' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [53] + 'experimental::signatures' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [56] + 'experimental::smartmatch' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [54] + 'experimental::win32_perlio' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [62] 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [47] 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [46] 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23] 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24] - 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [5..11,58] + 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [5..11,57] 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] - 'locale' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [64] + 'locale' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [63] 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25] 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12] - 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [65] + 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [64] 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [48] 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [49] @@ -215,7 +212,7 @@ our %DeadBits = ( 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [36] 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18] 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19] - 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [66] + 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [65] 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20] 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [37] 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [38] @@ -224,7 +221,7 @@ our %DeadBits = ( 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27] 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [50] 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00\x00\x00\x00", # [28..38,47] - 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [58] + 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [57] 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [39] 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [40] 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [41] @@ -237,8 +234,8 @@ our %DeadBits = ( # These are used by various things, including our own tests our $NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; -our $DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x45\x55\x01", # [2,59,60,52,53,56,61,62,54,57,55,63,4,64,22,23,25] -our $LAST_BIT = 134 ; +our $DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x51\x55\x00", # [2,58,59,52,55,60,61,53,56,54,62,4,63,22,23,25] +our $LAST_BIT = 132 ; our $BYTES = 17 ; our $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; @@ -729,8 +726,6 @@ The current hierarchy is: | | | +- experimental::lexical_subs | | - | +- experimental::lexical_topic - | | | +- experimental::postderef | | | +- experimental::re_strict @@ -1020,8 +1015,10 @@ this snippet of code: package MyMod::Abc; sub open { - warnings::warnif("deprecated", - "open is deprecated, use new instead"); + if (warnings::enabled("deprecated")) { + warnings::warn("deprecated", + "open is deprecated, use new instead"); + } new(@_); } diff --git a/make_ext.pl b/make_ext.pl index 1b055c3..f6d9e0f 100644 --- a/make_ext.pl +++ b/make_ext.pl @@ -612,6 +612,7 @@ sub just_pm_to_blib { my ($first) = $mname =~ /^([^:]+)/; my $pm_to_blib = IS_VMS ? 'pm_to_blib.ts' : 'pm_to_blib'; + my $silent = defined $ENV{MAKEFLAGS} and $ENV{MAKEFLAGS} =~ /\b(s|silent|quiet)\b/; foreach my $leaf (<*>) { if (-d $leaf) { @@ -656,7 +657,8 @@ sub just_pm_to_blib { die "Inconsistent module $mname has both lib/ and $first/" if $has_lib && $has_topdir; - print "\nRunning pm_to_blib for $ext_dir directly\n"; + print "\nRunning pm_to_blib for $ext_dir directly\n" + unless $silent; my %pm; if ($has_top) { diff --git a/makedef.pl b/makedef.pl index d1adad0..05252cf 100644 --- a/makedef.pl +++ b/makedef.pl @@ -939,6 +939,7 @@ elsif ($ARGS{PLATFORM} eq 'vms') { Perl_my_getpwuid Perl_my_gmtime Perl_my_kill + Perl_my_killpg Perl_my_localtime Perl_my_mkdir Perl_my_sigaction diff --git a/mg.c b/mg.c index 8ebb6a3..0f1c314 100644 --- a/mg.c +++ b/mg.c @@ -1041,6 +1041,11 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) *PL_compiling.cop_warnings); } } +#ifdef WIN32 + else if (strEQ(remaining, "IN32_SLOPPY_STAT")) { + sv_setiv(sv, w32_sloppystat); + } +#endif break; case '+': if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { @@ -1810,7 +1815,9 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); - EXTEND(SP, argc+1); + /* EXTEND() expects a signed argc; don't wrap when casting */ + assert(argc <= I32_MAX); + EXTEND(SP, (I32)argc+1); PUSHs(SvTIED_obj(sv, mg)); if (flags & G_UNDEF_FILL) { while (argc--) { @@ -2800,6 +2807,11 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } } } +#ifdef WIN32 + else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) { + w32_sloppystat = (bool)sv_true(sv); + } +#endif break; case '.': if (PL_localizing) { diff --git a/op.c b/op.c index 745cb5f..0c2af88 100644 --- a/op.c +++ b/op.c @@ -594,7 +594,7 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) !(is_our || isALPHA(name[1]) || ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) || - (name[1] == '_' && (*name == '$' || len > 2)))) + (name[1] == '_' && len > 2))) { if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) && isASCII(name[1]) @@ -607,13 +607,6 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8); } } - else if (len == 2 && name[1] == '_' && !is_our) - /* diag_listed_as: Use of my $_ is experimental */ - Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC), - "Use of %s $_ is experimental", - PL_parser->in_my == KEY_state - ? "state" - : "my"); /* allocate a spare slot and store the name in that slot */ @@ -2799,6 +2792,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) OP *kid = cUNOPo->op_first; CV *cv; GV *gv; + SV *namesv; if (kid->op_type != OP_PUSHMARK) { if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) @@ -2836,6 +2830,15 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) break; if (CvLVALUE(cv)) break; + if (flags & OP_LVALUE_NO_CROAK) + return NULL; + + namesv = cv_name(cv, NULL, 0); + yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue " + "subroutine call of &%"SVf" in %s", + SVfARG(namesv), PL_op_desc[type]), + SvUTF8(namesv)); + return o; } } /* FALLTHROUGH */ @@ -2849,9 +2852,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) yyerror(Perl_form(aTHX_ "Can't modify %s in %s", (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) ? "do block" - : (o->op_type == OP_ENTERSUB - ? "non-lvalue subroutine call" - : OP_DESC(o))), + : OP_DESC(o)), type ? PL_op_desc[type] : "local")); return o; @@ -5809,9 +5810,7 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) /* =for apidoc Am|OP *|newDEFSVOP| -Constructs and returns an op to access C<$_>, either as a lexical -variable (if declared as C) in the current scope, or the -global C<$_>. +Constructs and returns an op to access C<$_>. =cut */ @@ -5819,15 +5818,7 @@ global C<$_>. OP * Perl_newDEFSVOP(pTHX) { - const PADOFFSET offset = pad_findmy_pvs("$_", 0); - if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); - } - else { - OP * const o = newOP(OP_PADSV, 0); - o->op_targ = offset; - return o; - } } #ifdef USE_ITHREADS @@ -7224,7 +7215,7 @@ loop (iteration through a list of values). This is a heavyweight loop, with structure that allows exiting the loop by C and suchlike. C optionally supplies the variable that will be aliased to each -item in turn; if null, it defaults to C<$_> (either lexical or global). +item in turn; if null, it defaults to C<$_>. C supplies the list of values to iterate over. C supplies the main body of the loop, and C optionally supplies a C block that operates as a second half of the body. All of these optree @@ -7287,13 +7278,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) } } else { - const PADOFFSET offset = pad_findmy_pvs("$_", 0); - if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { - sv = newGVOP(OP_GV, 0, PL_defgv); - } - else { - padoff = offset; - } + sv = newGVOP(OP_GV, 0, PL_defgv); iterpflags |= OPpITER_DEF; } @@ -7475,9 +7460,10 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, OP *o; PERL_ARGS_ASSERT_NEWGIVWHENOP; + PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */ enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL); - enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg); + enterop->op_targ = 0; enterop->op_private = 0; o = newUNOP(leave_opcode, 0, (OP *) enterop); @@ -7596,8 +7582,7 @@ Constructs, checks, and returns an op tree expressing a C block. C supplies the expression that will be locally assigned to a lexical variable, and C supplies the body of the C construct; they are consumed by this function and become part of the constructed op tree. -C is the pad offset of the scalar lexical variable that will -be affected. If it is 0, the global C<$_> will be used. +C must be zero (it used to identity the pad slot of lexical $_). =cut */ @@ -7606,11 +7591,14 @@ OP * Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) { PERL_ARGS_ASSERT_NEWGIVENOP; + PERL_UNUSED_ARG(defsv_off); + + assert(!defsv_off); return newGIVWHENOP( ref_array_or_hash(cond), block, OP_ENTERGIVEN, OP_LEAVEGIVEN, - defsv_off); + 0); } /* @@ -10047,7 +10035,6 @@ Perl_ck_grep(pTHX_ OP *o) LOGOP *gwop; OP *kid; const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; - PADOFFSET offset; PERL_ARGS_ASSERT_CK_GREP; @@ -10074,15 +10061,8 @@ Perl_ck_grep(pTHX_ OP *o) gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid)); kid->op_next = (OP*)gwop; - offset = pad_findmy_pvs("$_", 0); - if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { - o->op_private = gwop->op_private = 0; - gwop->op_targ = pad_alloc(type, SVs_PADTMP); - } - else { - o->op_private = gwop->op_private = OPpGREP_LEX; - gwop->op_targ = o->op_targ = offset; - } + o->op_private = gwop->op_private = 0; + gwop->op_targ = pad_alloc(type, SVs_PADTMP); kid = OpSIBLING(cLISTOPo->op_first); for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid)) @@ -10336,13 +10316,6 @@ Perl_ck_match(pTHX_ OP *o) PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_CK_MATCH; - if (o->op_type != OP_QR && PL_compcv) { - const PADOFFSET offset = pad_findmy_pvs("$_", 0); - if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) { - o->op_targ = offset; - o->op_private |= OPpTARGET_MY; - } - } if (o->op_type == OP_MATCH || o->op_type == OP_QR) o->op_private |= OPpRUNTIME; return o; @@ -12196,7 +12169,7 @@ enum { that's flagged OA_DANGEROUS */ AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's not in any of the categories above */ - AAS_DEFAV = 0x200, /* contains just a single '@_' on RHS */ + AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */ }; diff --git a/opcode.h b/opcode.h index d6fd683..2e03448 100644 --- a/opcode.h +++ b/opcode.h @@ -2191,7 +2191,6 @@ END_EXTERN_C #define OPpCOREARGS_DEREF2 0x02 #define OPpEVAL_HAS_HH 0x02 #define OPpFT_ACCESS 0x02 -#define OPpGREP_LEX 0x02 #define OPpHINT_STRICT_REFS 0x02 #define OPpSORT_INTEGER 0x02 #define OPpTRANS_TO_UTF 0x02 @@ -2340,7 +2339,6 @@ EXTCONST char PL_op_private_labels[] = { 'F','T','A','F','T','E','R','t','\0', 'F','T','S','T','A','C','K','E','D','\0', 'F','T','S','T','A','C','K','I','N','G','\0', - 'G','R','E','P','L','E','X','\0', 'G','R','O','W','S','\0', 'G','U','E','S','S','E','D','\0', 'H','A','S','_','H','H','\0', @@ -2410,7 +2408,7 @@ EXTCONST I16 PL_op_private_bitfields[] = { 0, 8, -1, 0, 8, -1, 4, -1, 1, 157, 2, 164, 3, 171, -1, - 4, -1, 0, 515, 1, 26, 2, 284, 3, 103, -1, + 4, -1, 0, 507, 1, 26, 2, 276, 3, 103, -1, }; @@ -2433,18 +2431,18 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 20, /* padhv */ -1, /* padany */ 26, /* pushre */ - 28, /* rv2gv */ - 35, /* rv2sv */ - 40, /* av2arylen */ - 42, /* rv2cv */ + 27, /* rv2gv */ + 34, /* rv2sv */ + 39, /* av2arylen */ + 41, /* rv2cv */ -1, /* anoncode */ 0, /* prototype */ 0, /* refgen */ 0, /* srefgen */ 0, /* ref */ - 49, /* bless */ - 50, /* backtick */ - 49, /* glob */ + 48, /* bless */ + 49, /* backtick */ + 48, /* glob */ 0, /* readline */ -1, /* rcatline */ 0, /* regcmaybe */ @@ -2453,19 +2451,19 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 26, /* match */ 26, /* qr */ 26, /* subst */ - 55, /* substcont */ - 57, /* trans */ - 57, /* transr */ - 65, /* sassign */ - 68, /* aassign */ + 54, /* substcont */ + 56, /* trans */ + 56, /* transr */ + 63, /* sassign */ + 66, /* aassign */ 0, /* chop */ 0, /* schop */ - 73, /* chomp */ - 73, /* schomp */ + 71, /* chomp */ + 71, /* schomp */ 0, /* defined */ 0, /* undef */ 0, /* study */ - 40, /* pos */ + 39, /* pos */ 0, /* preinc */ 0, /* i_preinc */ 0, /* predec */ @@ -2474,22 +2472,22 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 0, /* i_postinc */ 0, /* postdec */ 0, /* i_postdec */ - 75, /* pow */ - 75, /* multiply */ - 75, /* i_multiply */ - 75, /* divide */ - 75, /* i_divide */ - 75, /* modulo */ - 75, /* i_modulo */ - 77, /* repeat */ - 75, /* add */ - 75, /* i_add */ - 75, /* subtract */ - 75, /* i_subtract */ - 75, /* concat */ - 79, /* stringify */ - 75, /* left_shift */ - 75, /* right_shift */ + 73, /* pow */ + 73, /* multiply */ + 73, /* i_multiply */ + 73, /* divide */ + 73, /* i_divide */ + 73, /* modulo */ + 73, /* i_modulo */ + 75, /* repeat */ + 73, /* add */ + 73, /* i_add */ + 73, /* subtract */ + 73, /* i_subtract */ + 73, /* concat */ + 77, /* stringify */ + 73, /* left_shift */ + 73, /* right_shift */ 12, /* lt */ 12, /* i_lt */ 12, /* gt */ @@ -2514,9 +2512,9 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 12, /* bit_and */ 12, /* bit_xor */ 12, /* bit_or */ - 75, /* nbit_and */ - 75, /* nbit_xor */ - 75, /* nbit_or */ + 73, /* nbit_and */ + 73, /* nbit_xor */ + 73, /* nbit_or */ 12, /* sbit_and */ 12, /* sbit_xor */ 12, /* sbit_or */ @@ -2524,111 +2522,111 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 0, /* i_negate */ 0, /* not */ 0, /* complement */ - 73, /* ncomplement */ - 73, /* scomplement */ + 71, /* ncomplement */ + 71, /* scomplement */ 12, /* smartmatch */ - 79, /* atan2 */ - 73, /* sin */ - 73, /* cos */ - 79, /* rand */ - 79, /* srand */ - 73, /* exp */ - 73, /* log */ - 73, /* sqrt */ - 73, /* int */ - 73, /* hex */ - 73, /* oct */ - 73, /* abs */ - 73, /* length */ - 81, /* substr */ - 84, /* vec */ - 79, /* index */ - 79, /* rindex */ - 49, /* sprintf */ - 49, /* formline */ - 73, /* ord */ - 73, /* chr */ - 79, /* crypt */ + 77, /* atan2 */ + 71, /* sin */ + 71, /* cos */ + 77, /* rand */ + 77, /* srand */ + 71, /* exp */ + 71, /* log */ + 71, /* sqrt */ + 71, /* int */ + 71, /* hex */ + 71, /* oct */ + 71, /* abs */ + 71, /* length */ + 79, /* substr */ + 82, /* vec */ + 77, /* index */ + 77, /* rindex */ + 48, /* sprintf */ + 48, /* formline */ + 71, /* ord */ + 71, /* chr */ + 77, /* crypt */ 0, /* ucfirst */ 0, /* lcfirst */ 0, /* uc */ 0, /* lc */ 0, /* quotemeta */ - 86, /* rv2av */ - 92, /* aelemfast */ - 92, /* aelemfast_lex */ - 93, /* aelem */ - 98, /* aslice */ - 101, /* kvaslice */ + 84, /* rv2av */ + 90, /* aelemfast */ + 90, /* aelemfast_lex */ + 91, /* aelem */ + 96, /* aslice */ + 99, /* kvaslice */ 0, /* aeach */ 0, /* akeys */ 0, /* avalues */ 0, /* each */ 0, /* values */ - 40, /* keys */ - 102, /* delete */ - 105, /* exists */ - 107, /* rv2hv */ - 93, /* helem */ - 98, /* hslice */ - 101, /* kvhslice */ - 115, /* multideref */ - 49, /* unpack */ - 49, /* pack */ - 122, /* split */ - 49, /* join */ - 124, /* list */ + 39, /* keys */ + 100, /* delete */ + 103, /* exists */ + 105, /* rv2hv */ + 91, /* helem */ + 96, /* hslice */ + 99, /* kvhslice */ + 113, /* multideref */ + 48, /* unpack */ + 48, /* pack */ + 120, /* split */ + 48, /* join */ + 122, /* list */ 12, /* lslice */ - 49, /* anonlist */ - 49, /* anonhash */ - 49, /* splice */ - 79, /* push */ + 48, /* anonlist */ + 48, /* anonhash */ + 48, /* splice */ + 77, /* push */ 0, /* pop */ 0, /* shift */ - 79, /* unshift */ - 126, /* sort */ - 133, /* reverse */ - 135, /* grepstart */ - 135, /* grepwhile */ - 135, /* mapstart */ - 135, /* mapwhile */ + 77, /* unshift */ + 124, /* sort */ + 131, /* reverse */ + 0, /* grepstart */ + 0, /* grepwhile */ + 0, /* mapstart */ + 0, /* mapwhile */ 0, /* range */ - 137, /* flip */ - 137, /* flop */ + 133, /* flip */ + 133, /* flop */ 0, /* and */ 0, /* or */ 12, /* xor */ 0, /* dor */ - 139, /* cond_expr */ + 135, /* cond_expr */ 0, /* andassign */ 0, /* orassign */ 0, /* dorassign */ 0, /* method */ - 141, /* entersub */ - 148, /* leavesub */ - 148, /* leavesublv */ - 150, /* caller */ - 49, /* warn */ - 49, /* die */ - 49, /* reset */ + 137, /* entersub */ + 144, /* leavesub */ + 144, /* leavesublv */ + 146, /* caller */ + 48, /* warn */ + 48, /* die */ + 48, /* reset */ -1, /* lineseq */ - 152, /* nextstate */ - 152, /* dbstate */ + 148, /* nextstate */ + 148, /* dbstate */ -1, /* unstack */ -1, /* enter */ - 153, /* leave */ + 149, /* leave */ -1, /* scope */ - 155, /* enteriter */ - 159, /* iter */ + 151, /* enteriter */ + 155, /* iter */ -1, /* enterloop */ - 160, /* leaveloop */ + 156, /* leaveloop */ -1, /* return */ - 162, /* last */ - 162, /* next */ - 162, /* redo */ - 162, /* dump */ - 162, /* goto */ - 49, /* exit */ + 158, /* last */ + 158, /* next */ + 158, /* redo */ + 158, /* dump */ + 158, /* goto */ + 48, /* exit */ 0, /* method_named */ 0, /* method_super */ 0, /* method_redir */ @@ -2639,143 +2637,143 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 0, /* leavewhen */ -1, /* break */ -1, /* continue */ - 164, /* open */ - 49, /* close */ - 49, /* pipe_op */ - 49, /* fileno */ - 49, /* umask */ - 49, /* binmode */ - 49, /* tie */ + 160, /* open */ + 48, /* close */ + 48, /* pipe_op */ + 48, /* fileno */ + 48, /* umask */ + 48, /* binmode */ + 48, /* tie */ 0, /* untie */ 0, /* tied */ - 49, /* dbmopen */ + 48, /* dbmopen */ 0, /* dbmclose */ - 49, /* sselect */ - 49, /* select */ - 49, /* getc */ - 49, /* read */ - 49, /* enterwrite */ - 148, /* leavewrite */ + 48, /* sselect */ + 48, /* select */ + 48, /* getc */ + 48, /* read */ + 48, /* enterwrite */ + 144, /* leavewrite */ -1, /* prtf */ -1, /* print */ -1, /* say */ - 49, /* sysopen */ - 49, /* sysseek */ - 49, /* sysread */ - 49, /* syswrite */ - 49, /* eof */ - 49, /* tell */ - 49, /* seek */ - 49, /* truncate */ - 49, /* fcntl */ - 49, /* ioctl */ - 79, /* flock */ - 49, /* send */ - 49, /* recv */ - 49, /* socket */ - 49, /* sockpair */ - 49, /* bind */ - 49, /* connect */ - 49, /* listen */ - 49, /* accept */ - 49, /* shutdown */ - 49, /* gsockopt */ - 49, /* ssockopt */ + 48, /* sysopen */ + 48, /* sysseek */ + 48, /* sysread */ + 48, /* syswrite */ + 48, /* eof */ + 48, /* tell */ + 48, /* seek */ + 48, /* truncate */ + 48, /* fcntl */ + 48, /* ioctl */ + 77, /* flock */ + 48, /* send */ + 48, /* recv */ + 48, /* socket */ + 48, /* sockpair */ + 48, /* bind */ + 48, /* connect */ + 48, /* listen */ + 48, /* accept */ + 48, /* shutdown */ + 48, /* gsockopt */ + 48, /* ssockopt */ 0, /* getsockname */ 0, /* getpeername */ 0, /* lstat */ 0, /* stat */ - 169, /* ftrread */ - 169, /* ftrwrite */ - 169, /* ftrexec */ - 169, /* fteread */ - 169, /* ftewrite */ - 169, /* fteexec */ - 174, /* ftis */ - 174, /* ftsize */ - 174, /* ftmtime */ - 174, /* ftatime */ - 174, /* ftctime */ - 174, /* ftrowned */ - 174, /* fteowned */ - 174, /* ftzero */ - 174, /* ftsock */ - 174, /* ftchr */ - 174, /* ftblk */ - 174, /* ftfile */ - 174, /* ftdir */ - 174, /* ftpipe */ - 174, /* ftsuid */ - 174, /* ftsgid */ - 174, /* ftsvtx */ - 174, /* ftlink */ - 174, /* fttty */ - 174, /* fttext */ - 174, /* ftbinary */ - 79, /* chdir */ - 79, /* chown */ - 73, /* chroot */ - 79, /* unlink */ - 79, /* chmod */ - 79, /* utime */ - 79, /* rename */ - 79, /* link */ - 79, /* symlink */ + 165, /* ftrread */ + 165, /* ftrwrite */ + 165, /* ftrexec */ + 165, /* fteread */ + 165, /* ftewrite */ + 165, /* fteexec */ + 170, /* ftis */ + 170, /* ftsize */ + 170, /* ftmtime */ + 170, /* ftatime */ + 170, /* ftctime */ + 170, /* ftrowned */ + 170, /* fteowned */ + 170, /* ftzero */ + 170, /* ftsock */ + 170, /* ftchr */ + 170, /* ftblk */ + 170, /* ftfile */ + 170, /* ftdir */ + 170, /* ftpipe */ + 170, /* ftsuid */ + 170, /* ftsgid */ + 170, /* ftsvtx */ + 170, /* ftlink */ + 170, /* fttty */ + 170, /* fttext */ + 170, /* ftbinary */ + 77, /* chdir */ + 77, /* chown */ + 71, /* chroot */ + 77, /* unlink */ + 77, /* chmod */ + 77, /* utime */ + 77, /* rename */ + 77, /* link */ + 77, /* symlink */ 0, /* readlink */ - 79, /* mkdir */ - 73, /* rmdir */ - 49, /* open_dir */ + 77, /* mkdir */ + 71, /* rmdir */ + 48, /* open_dir */ 0, /* readdir */ 0, /* telldir */ - 49, /* seekdir */ + 48, /* seekdir */ 0, /* rewinddir */ 0, /* closedir */ -1, /* fork */ - 178, /* wait */ - 79, /* waitpid */ - 79, /* system */ - 79, /* exec */ - 79, /* kill */ - 178, /* getppid */ - 79, /* getpgrp */ - 79, /* setpgrp */ - 79, /* getpriority */ - 79, /* setpriority */ - 178, /* time */ + 174, /* wait */ + 77, /* waitpid */ + 77, /* system */ + 77, /* exec */ + 77, /* kill */ + 174, /* getppid */ + 77, /* getpgrp */ + 77, /* setpgrp */ + 77, /* getpriority */ + 77, /* setpriority */ + 174, /* time */ -1, /* tms */ 0, /* localtime */ - 49, /* gmtime */ + 48, /* gmtime */ 0, /* alarm */ - 79, /* sleep */ - 49, /* shmget */ - 49, /* shmctl */ - 49, /* shmread */ - 49, /* shmwrite */ - 49, /* msgget */ - 49, /* msgctl */ - 49, /* msgsnd */ - 49, /* msgrcv */ - 49, /* semop */ - 49, /* semget */ - 49, /* semctl */ + 77, /* sleep */ + 48, /* shmget */ + 48, /* shmctl */ + 48, /* shmread */ + 48, /* shmwrite */ + 48, /* msgget */ + 48, /* msgctl */ + 48, /* msgsnd */ + 48, /* msgrcv */ + 48, /* semop */ + 48, /* semget */ + 48, /* semctl */ 0, /* require */ 0, /* dofile */ -1, /* hintseval */ - 179, /* entereval */ - 148, /* leaveeval */ + 175, /* entereval */ + 144, /* leaveeval */ 0, /* entertry */ -1, /* leavetry */ 0, /* ghbyname */ - 49, /* ghbyaddr */ + 48, /* ghbyaddr */ -1, /* ghostent */ 0, /* gnbyname */ - 49, /* gnbyaddr */ + 48, /* gnbyaddr */ -1, /* gnetent */ 0, /* gpbyname */ - 49, /* gpbynumber */ + 48, /* gpbynumber */ -1, /* gprotoent */ - 49, /* gsbyname */ - 49, /* gsbyport */ + 48, /* gsbyname */ + 48, /* gsbyport */ -1, /* gservent */ 0, /* shostent */ 0, /* snetent */ @@ -2796,21 +2794,21 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { -1, /* sgrent */ -1, /* egrent */ -1, /* getlogin */ - 49, /* syscall */ + 48, /* syscall */ 0, /* lock */ 0, /* once */ -1, /* custom */ - 185, /* coreargs */ + 181, /* coreargs */ 3, /* runcv */ 0, /* fc */ -1, /* padcv */ -1, /* introcv */ -1, /* clonecv */ - 189, /* padrange */ - 191, /* refassign */ - 197, /* lvref */ - 203, /* lvrefslice */ - 204, /* lvavref */ + 185, /* padrange */ + 187, /* refassign */ + 193, /* lvref */ + 199, /* lvrefslice */ + 200, /* lvavref */ 0, /* anonconst */ }; @@ -2830,69 +2828,68 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { */ EXTCONST U16 PL_op_private_bitdefs[] = { - 0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, akeys, avalues, each, values, pop, shift, range, and, or, dor, andassign, orassign, dorassign, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst */ - 0x2c5c, 0x3e59, /* pushmark */ + 0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, akeys, avalues, each, values, pop, shift, grepstart, grepwhile, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst */ + 0x2b5c, 0x3d59, /* pushmark */ 0x00bd, /* wantarray, runcv */ - 0x03b8, 0x17f0, 0x3f0c, 0x39c8, 0x3025, /* const */ - 0x2c5c, 0x3179, /* gvsv */ + 0x03b8, 0x17f0, 0x3e0c, 0x38c8, 0x2f25, /* const */ + 0x2b5c, 0x3079, /* gvsv */ 0x1655, /* gv */ 0x0067, /* gelem, lt, i_lt, gt, i_gt, le, i_le, ge, i_ge, eq, i_eq, ne, i_ne, ncmp, i_ncmp, slt, sgt, sle, sge, seq, sne, scmp, bit_and, bit_xor, bit_or, sbit_and, sbit_xor, sbit_or, smartmatch, lslice, xor */ - 0x2c5c, 0x3e58, 0x0257, /* padsv */ - 0x2c5c, 0x3e58, 0x2d4c, 0x3b49, /* padav */ - 0x2c5c, 0x3e58, 0x0534, 0x05d0, 0x2d4c, 0x3b49, /* padhv */ - 0x3918, 0x4171, /* pushre, match, qr, subst */ - 0x2c5c, 0x19d8, 0x0256, 0x2d4c, 0x2f48, 0x3f04, 0x0003, /* rv2gv */ - 0x2c5c, 0x3178, 0x0256, 0x3f04, 0x0003, /* rv2sv */ - 0x2d4c, 0x0003, /* av2arylen, pos, keys */ - 0x2ebc, 0x0e18, 0x0b74, 0x028c, 0x40c8, 0x3f04, 0x0003, /* rv2cv */ + 0x2b5c, 0x3d58, 0x0257, /* padsv */ + 0x2b5c, 0x3d58, 0x2c4c, 0x3a49, /* padav */ + 0x2b5c, 0x3d58, 0x0534, 0x05d0, 0x2c4c, 0x3a49, /* padhv */ + 0x3819, /* pushre, match, qr, subst */ + 0x2b5c, 0x19d8, 0x0256, 0x2c4c, 0x2e48, 0x3e04, 0x0003, /* rv2gv */ + 0x2b5c, 0x3078, 0x0256, 0x3e04, 0x0003, /* rv2sv */ + 0x2c4c, 0x0003, /* av2arylen, pos, keys */ + 0x2dbc, 0x0e18, 0x0b74, 0x028c, 0x3fc8, 0x3e04, 0x0003, /* rv2cv */ 0x012f, /* bless, glob, sprintf, formline, unpack, pack, join, anonlist, anonhash, splice, warn, die, reset, exit, close, pipe_op, fileno, umask, binmode, tie, dbmopen, sselect, select, getc, read, enterwrite, sysopen, sysseek, sysread, syswrite, eof, tell, seek, truncate, fcntl, ioctl, send, recv, socket, sockpair, bind, connect, listen, accept, shutdown, gsockopt, ssockopt, open_dir, seekdir, gmtime, shmget, shmctl, shmread, shmwrite, msgget, msgctl, msgsnd, msgrcv, semop, semget, semctl, ghbyaddr, gnbyaddr, gpbynumber, gsbyname, gsbyport, syscall */ - 0x335c, 0x3278, 0x2734, 0x2670, 0x0003, /* backtick */ - 0x3918, 0x0003, /* substcont */ - 0x0f1c, 0x2058, 0x0754, 0x4170, 0x3c8c, 0x23e8, 0x01e4, 0x0141, /* trans, transr */ + 0x325c, 0x3178, 0x2634, 0x2570, 0x0003, /* backtick */ + 0x3818, 0x0003, /* substcont */ + 0x0f1c, 0x1f58, 0x0754, 0x3b8c, 0x22e8, 0x01e4, 0x0141, /* trans, transr */ 0x0d5c, 0x0458, 0x0067, /* sassign */ - 0x0a18, 0x0914, 0x0810, 0x2d4c, 0x0067, /* aassign */ - 0x4170, 0x0003, /* chomp, schomp, ncomplement, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, length, ord, chr, chroot, rmdir */ - 0x4170, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract, concat, left_shift, right_shift, nbit_and, nbit_xor, nbit_or */ + 0x0a18, 0x0914, 0x0810, 0x2c4c, 0x0067, /* aassign */ + 0x4070, 0x0003, /* chomp, schomp, ncomplement, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, length, ord, chr, chroot, rmdir */ + 0x4070, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract, concat, left_shift, right_shift, nbit_and, nbit_xor, nbit_or */ 0x12d8, 0x0067, /* repeat */ - 0x4170, 0x012f, /* stringify, atan2, rand, srand, index, rindex, crypt, push, unshift, flock, chdir, chown, unlink, chmod, utime, rename, link, symlink, mkdir, waitpid, system, exec, kill, getpgrp, setpgrp, getpriority, setpriority, sleep */ - 0x3670, 0x2d4c, 0x00cb, /* substr */ - 0x2d4c, 0x0067, /* vec */ - 0x2c5c, 0x3178, 0x2d4c, 0x3b48, 0x3f04, 0x0003, /* rv2av */ + 0x4070, 0x012f, /* stringify, atan2, rand, srand, index, rindex, crypt, push, unshift, flock, chdir, chown, unlink, chmod, utime, rename, link, symlink, mkdir, waitpid, system, exec, kill, getpgrp, setpgrp, getpriority, setpriority, sleep */ + 0x3570, 0x2c4c, 0x00cb, /* substr */ + 0x2c4c, 0x0067, /* vec */ + 0x2b5c, 0x3078, 0x2c4c, 0x3a48, 0x3e04, 0x0003, /* rv2av */ 0x01ff, /* aelemfast, aelemfast_lex */ - 0x2c5c, 0x2b58, 0x0256, 0x2d4c, 0x0067, /* aelem, helem */ - 0x2c5c, 0x2d4c, 0x3b49, /* aslice, hslice */ - 0x2d4d, /* kvaslice, kvhslice */ - 0x2c5c, 0x3a98, 0x0003, /* delete */ - 0x3ff8, 0x0003, /* exists */ - 0x2c5c, 0x3178, 0x0534, 0x05d0, 0x2d4c, 0x3b48, 0x3f04, 0x0003, /* rv2hv */ - 0x2c5c, 0x2b58, 0x0f94, 0x18f0, 0x2d4c, 0x3f04, 0x0003, /* multideref */ - 0x24bc, 0x3179, /* split */ - 0x2c5c, 0x2119, /* list */ - 0x3d78, 0x3414, 0x1230, 0x27cc, 0x3768, 0x28c4, 0x30e1, /* sort */ - 0x27cc, 0x0003, /* reverse */ - 0x1f44, 0x0003, /* grepstart, grepwhile, mapstart, mapwhile */ - 0x29f8, 0x0003, /* flip, flop */ - 0x2c5c, 0x0003, /* cond_expr */ - 0x2c5c, 0x0e18, 0x0256, 0x028c, 0x40c8, 0x3f04, 0x2581, /* entersub */ - 0x34d8, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */ + 0x2b5c, 0x2a58, 0x0256, 0x2c4c, 0x0067, /* aelem, helem */ + 0x2b5c, 0x2c4c, 0x3a49, /* aslice, hslice */ + 0x2c4d, /* kvaslice, kvhslice */ + 0x2b5c, 0x3998, 0x0003, /* delete */ + 0x3ef8, 0x0003, /* exists */ + 0x2b5c, 0x3078, 0x0534, 0x05d0, 0x2c4c, 0x3a48, 0x3e04, 0x0003, /* rv2hv */ + 0x2b5c, 0x2a58, 0x0f94, 0x18f0, 0x2c4c, 0x3e04, 0x0003, /* multideref */ + 0x23bc, 0x3079, /* split */ + 0x2b5c, 0x2019, /* list */ + 0x3c78, 0x3314, 0x1230, 0x26cc, 0x3668, 0x27c4, 0x2fe1, /* sort */ + 0x26cc, 0x0003, /* reverse */ + 0x28f8, 0x0003, /* flip, flop */ + 0x2b5c, 0x0003, /* cond_expr */ + 0x2b5c, 0x0e18, 0x0256, 0x028c, 0x3fc8, 0x3e04, 0x2481, /* entersub */ + 0x33d8, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */ 0x00bc, 0x012f, /* caller */ - 0x22f5, /* nextstate, dbstate */ - 0x2afc, 0x34d9, /* leave */ - 0x2c5c, 0x3178, 0x0e8c, 0x37e9, /* enteriter */ - 0x37e9, /* iter */ - 0x2afc, 0x0067, /* leaveloop */ - 0x42dc, 0x0003, /* last, next, redo, dump, goto */ - 0x335c, 0x3278, 0x2734, 0x2670, 0x012f, /* open */ + 0x21f5, /* nextstate, dbstate */ + 0x29fc, 0x33d9, /* leave */ + 0x2b5c, 0x3078, 0x0e8c, 0x36e9, /* enteriter */ + 0x36e9, /* iter */ + 0x29fc, 0x0067, /* leaveloop */ + 0x41dc, 0x0003, /* last, next, redo, dump, goto */ + 0x325c, 0x3178, 0x2634, 0x2570, 0x012f, /* open */ 0x1b90, 0x1dec, 0x1ca8, 0x1a64, 0x0003, /* ftrread, ftrwrite, ftrexec, fteread, ftewrite, fteexec */ 0x1b90, 0x1dec, 0x1ca8, 0x0003, /* ftis, ftsize, ftmtime, ftatime, ftctime, ftrowned, fteowned, ftzero, ftsock, ftchr, ftblk, ftfile, ftdir, ftpipe, ftsuid, ftsgid, ftsvtx, ftlink, fttty, fttext, ftbinary */ - 0x4171, /* wait, getppid, time */ - 0x3574, 0x0c30, 0x068c, 0x4248, 0x2204, 0x0003, /* entereval */ - 0x2e1c, 0x0018, 0x1144, 0x1061, /* coreargs */ - 0x2c5c, 0x019b, /* padrange */ - 0x2c5c, 0x3e58, 0x0376, 0x294c, 0x1748, 0x0067, /* refassign */ - 0x2c5c, 0x3e58, 0x0376, 0x294c, 0x1748, 0x0003, /* lvref */ - 0x2c5d, /* lvrefslice */ - 0x2c5c, 0x3e58, 0x0003, /* lvavref */ + 0x4071, /* wait, getppid, time */ + 0x3474, 0x0c30, 0x068c, 0x4148, 0x2104, 0x0003, /* entereval */ + 0x2d1c, 0x0018, 0x1144, 0x1061, /* coreargs */ + 0x2b5c, 0x019b, /* padrange */ + 0x2b5c, 0x3d58, 0x0376, 0x284c, 0x1748, 0x0067, /* refassign */ + 0x2b5c, 0x3d58, 0x0376, 0x284c, 0x1748, 0x0003, /* lvref */ + 0x2b5d, /* lvrefslice */ + 0x2b5c, 0x3d58, 0x0003, /* lvavref */ }; @@ -2914,7 +2911,7 @@ EXTCONST U8 PL_op_private_valid[] = { /* PADAV */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpPAD_STATE|OPpLVAL_INTRO), /* PADHV */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpMAYBE_TRUEBOOL|OPpTRUEBOOL|OPpPAD_STATE|OPpLVAL_INTRO), /* PADANY */ (0), - /* PUSHRE */ (OPpTARGET_MY|OPpRUNTIME), + /* PUSHRE */ (OPpRUNTIME), /* RV2GV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpDONT_INIT_GV|OPpMAYBE_LVSUB|OPpDEREF|OPpALLOW_FAKE|OPpLVAL_INTRO), /* RV2SV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpDEREF|OPpOUR_INTRO|OPpLVAL_INTRO), /* AV2ARYLEN */ (OPpARG1_MASK|OPpMAYBE_LVSUB), @@ -2932,12 +2929,12 @@ EXTCONST U8 PL_op_private_valid[] = { /* REGCMAYBE */ (OPpARG1_MASK), /* REGCRESET */ (OPpARG1_MASK), /* REGCOMP */ (OPpARG1_MASK), - /* MATCH */ (OPpTARGET_MY|OPpRUNTIME), - /* QR */ (OPpTARGET_MY|OPpRUNTIME), - /* SUBST */ (OPpTARGET_MY|OPpRUNTIME), + /* MATCH */ (OPpRUNTIME), + /* QR */ (OPpRUNTIME), + /* SUBST */ (OPpRUNTIME), /* SUBSTCONT */ (OPpARG1_MASK|OPpRUNTIME), - /* TRANS */ (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTARGET_MY|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE), - /* TRANSR */ (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTARGET_MY|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE), + /* TRANS */ (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE), + /* TRANSR */ (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE), /* SASSIGN */ (OPpARG2_MASK|OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV), /* AASSIGN */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpASSIGN_COMMON_AGG|OPpASSIGN_COMMON_RC1|OPpASSIGN_COMMON_SCALAR), /* CHOP */ (OPpARG1_MASK), @@ -3070,10 +3067,10 @@ EXTCONST U8 PL_op_private_valid[] = { /* UNSHIFT */ (OPpARG4_MASK|OPpTARGET_MY), /* SORT */ (OPpSORT_NUMERIC|OPpSORT_INTEGER|OPpSORT_REVERSE|OPpSORT_INPLACE|OPpSORT_DESCEND|OPpSORT_QSORT|OPpSORT_STABLE), /* REVERSE */ (OPpARG1_MASK|OPpREVERSE_INPLACE), - /* GREPSTART */ (OPpARG1_MASK|OPpGREP_LEX), - /* GREPWHILE */ (OPpARG1_MASK|OPpGREP_LEX), - /* MAPSTART */ (OPpARG1_MASK|OPpGREP_LEX), - /* MAPWHILE */ (OPpARG1_MASK|OPpGREP_LEX), + /* GREPSTART */ (OPpARG1_MASK), + /* GREPWHILE */ (OPpARG1_MASK), + /* MAPSTART */ (OPpARG1_MASK), + /* MAPWHILE */ (OPpARG1_MASK), /* RANGE */ (OPpARG1_MASK), /* FLIP */ (OPpARG1_MASK|OPpFLIP_LINENUM), /* FLOP */ (OPpARG1_MASK|OPpFLIP_LINENUM), diff --git a/pad.c b/pad.c index 421cd43..9773a25 100644 --- a/pad.c +++ b/pad.c @@ -1035,11 +1035,12 @@ Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags) /* =for apidoc Amp|PADOFFSET|find_rundefsvoffset -Find the position of the lexical C<$_> in the pad of the -currently-executing function. Returns the offset in the current pad, -or C if there is no lexical C<$_> in scope (in which case -the global one should be used instead). -L is likely to be more convenient. +Until the lexical C<$_> feature was removed, this function would +find the position of the lexical C<$_> in the pad of the +currently-executing function and returns the offset in the current pad, +or C. + +Now it always returns C. =cut */ @@ -1047,18 +1048,14 @@ L is likely to be more convenient. PADOFFSET Perl_find_rundefsvoffset(pTHX) { - PADNAME *out_pn; - int out_flags; - return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1, - NULL, &out_pn, &out_flags); + PERL_UNUSED_CONTEXT; /* Can we just remove the pTHX from the sig? */ + return NOT_IN_PAD; } /* =for apidoc Am|SV *|find_rundefsv -Find and return the variable that is named C<$_> in the lexical scope -of the currently-executing function. This may be a lexical C<$_>, -or will otherwise be the global one. +Returns the global variable C<$_>. =cut */ @@ -1066,35 +1063,7 @@ or will otherwise be the global one. SV * Perl_find_rundefsv(pTHX) { - PADNAME *name; - int flags; - PADOFFSET po; - - po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1, - NULL, &name, &flags); - - if (po == NOT_IN_PAD || PadnameIsOUR(name)) - return DEFSV; - - return PAD_SVl(po); -} - -SV * -Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq) -{ - PADNAME *name; - int flags; - PADOFFSET po; - - PERL_ARGS_ASSERT_FIND_RUNDEFSV2; - - po = pad_findlex("$_", 2, 0, cv, seq, 1, - NULL, &name, &flags); - - if (po == NOT_IN_PAD || PadnameIsOUR(name)) - return DEFSV; - - return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po]; + return DEFSV; } /* diff --git a/patchlevel.h b/patchlevel.h index 3f80765..a96afea 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -15,7 +15,7 @@ #define PERL_REVISION 5 /* age */ #define PERL_VERSION 23 /* epoch */ -#define PERL_SUBVERSION 3 /* generation */ +#define PERL_SUBVERSION 4 /* generation */ /* The following numbers describe the earliest compatible version of Perl ("compatibility" here being defined as sufficient binary/API @@ -36,7 +36,7 @@ */ #define PERL_API_REVISION 5 #define PERL_API_VERSION 23 -#define PERL_API_SUBVERSION 3 +#define PERL_API_SUBVERSION 4 /* XXX Note: The selection of non-default Configure options, such as -Duselonglong may invalidate these settings. Currently, Configure diff --git a/perl.c b/perl.c index 1bd2cbb..e3d6545 100644 --- a/perl.c +++ b/perl.c @@ -1485,8 +1485,8 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); if (s && strEQ(s, "1")) { - unsigned char *seed= PERL_HASH_SEED; - unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES; + const unsigned char *seed= PERL_HASH_SEED; + const unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES; PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC); while (seed < seed_end) { PerlIO_printf(Perl_debug_log, "%02x", *seed++); @@ -1787,6 +1787,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef USE_LOCALE_CTYPE " USE_LOCALE_CTYPE" # endif +# ifdef WIN32_NO_REGISTRY + " USE_NO_REGISTRY" +# endif # ifdef USE_PERL_ATOF " USE_PERL_ATOF" # endif @@ -2696,7 +2699,7 @@ I32 Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) /* See G_* flags in cop.h */ { - dVAR; dSP; + dVAR; LOGOP myop; /* fake syntax tree node */ METHOP method_op; I32 oldmark; @@ -2726,9 +2729,12 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) SAVEOP(); PL_op = (OP*)&myop; - EXTEND(PL_stack_sp, 1); - if (!(flags & G_METHOD_NAMED)) - *++PL_stack_sp = sv; + if (!(flags & G_METHOD_NAMED)) { + dSP; + EXTEND(SP, 1); + PUSHs(sv); + PUTBACK; + } oldmark = TOPMARK; oldscope = PL_scopestack_ix; @@ -2839,9 +2845,8 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* See G_* flags in cop.h */ { dVAR; - dSP; UNOP myop; /* fake syntax tree node */ - VOL I32 oldmark = SP - PL_stack_base; + VOL I32 oldmark; VOL I32 retval = 0; int ret; OP* const oldop = PL_op; @@ -2857,8 +2862,13 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) SAVEOP(); PL_op = (OP*)&myop; Zero(&myop, 1, UNOP); - EXTEND(PL_stack_sp, 1); - *++PL_stack_sp = sv; + { + dSP; + oldmark = SP - PL_stack_base; + EXTEND(SP, 1); + PUSHs(sv); + PUTBACK; + } if (!(flags & G_NOARGS)) myop.op_flags = OPf_STACKED; @@ -3824,14 +3834,6 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) return rsfp; } -/* Mention - * I_SYSSTATVFS HAS_FSTATVFS - * I_SYSMOUNT - * I_STATFS HAS_FSTATFS HAS_GETFSSTAT - * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT - * here so that metaconfig picks them up. */ - - #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW /* Don't even need this function. */ #else @@ -3848,16 +3850,13 @@ S_validate_suid(pTHX_ PerlIO *rsfp) if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */ dVAR; int fd = PerlIO_fileno(rsfp); - if (fd < 0) { - Perl_croak(aTHX_ "Illegal suidscript"); - } else { - if (PerlLIO_fstat(fd, &PL_statbuf) < 0) { /* may be either wrapped or real suid */ - Perl_croak(aTHX_ "Illegal suidscript"); - } + Stat_t statbuf; + if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */ + Perl_croak_nocontext( "Illegal suidscript"); } - if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID) + if ((my_euid != my_uid && my_euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) || - (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID) + (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) ) if (!PL_do_undump) Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ diff --git a/perl.h b/perl.h index a1a50b3..27afddb 100644 --- a/perl.h +++ b/perl.h @@ -35,7 +35,7 @@ * NOTE 2: headers lie. Do not expect that if HAS_C99 gets to be true, * all the C99 features are there and are correct. */ #if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || \ - defined(_STDC_C99) + defined(_STDC_C99) || defined(__c99) # define HAS_C99 1 #endif @@ -1965,11 +1965,15 @@ extern long double Perl_my_frexpl(long double x, int *e); # ifndef Perl_isnan # if defined(HAS_ISNANL) && !(defined(isnan) && defined(HAS_C99)) # define Perl_isnan(x) isnanl(x) +# elif defined(__sgi) && defined(__c99) /* XXX Configure test needed */ +# define Perl_isnan(x) isnan(x) # endif # endif # ifndef Perl_isinf # if defined(HAS_ISINFL) && !(defined(isinf) && defined(HAS_C99)) # define Perl_isinf(x) isinfl(x) +# elif defined(__sgi) && defined(__c99) /* XXX Configure test needed */ +# define Perl_isinf(x) isinf(x) # elif defined(LDBL_MAX) && !defined(NAN_COMPARE_BROKEN) # define Perl_isinf(x) ((x) > LDBL_MAX || (x) < -LDBL_MAX) # endif @@ -2157,7 +2161,7 @@ extern long double Perl_my_frexpl(long double x, int *e); /* Solaris and IRIX have fpclass/fpclassl, but they are using * an enum typedef, not cpp symbols, and Configure doesn't detect that. * Define some symbols also as cpp symbols so we can detect them. */ -# if defined(__sun) || defined(__irix__) /* XXX Configure test instead */ +# if defined(__sun) || defined(__sgi) /* XXX Configure test instead */ # define FP_PINF FP_PINF # define FP_QNAN FP_QNAN # endif @@ -2207,7 +2211,7 @@ extern long double Perl_my_frexpl(long double x, int *e); # include # endif # if defined(FP_POS_INF) && defined(FP_QNAN) -# ifdef __irix__ /* XXX Configure test instead */ +# ifdef __sgi /* XXX Configure test instead */ # ifdef USE_LONG_DOUBLE # define Perl_fp_class(x) fp_class_l(x) # else @@ -6485,14 +6489,6 @@ extern void moncontrol(int); /* See http://www.unicode.org/unicode/reports/tr13/ */ #define NEXT_LINE_CHAR NEXT_LINE_NATIVE -/* The UTF-8 bytes of the Unicode LS and PS, U+2028 and U+2029 */ -#define UNICODE_LINE_SEPA_0 0xE2 -#define UNICODE_LINE_SEPA_1 0x80 -#define UNICODE_LINE_SEPA_2 0xA8 -#define UNICODE_PARA_SEPA_0 0xE2 -#define UNICODE_PARA_SEPA_1 0x80 -#define UNICODE_PARA_SEPA_2 0xA9 - #ifndef PIPESOCK_MODE # define PIPESOCK_MODE #endif diff --git a/perlio.c b/perlio.c index ae8cbc9..8ab47e4 100644 --- a/perlio.c +++ b/perlio.c @@ -3332,6 +3332,12 @@ PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) return -1; SETERRNO(0,0); /* just in case */ } +#ifdef __sgi + /* Under some circumstances IRIX stdio fgetc() and fread() + * set the errno to ENOENT, which makes no sense according + * to either IRIX or POSIX. [rt.perl.org #123977] */ + if (errno == ENOENT) SETERRNO(0,0); +#endif return got; } diff --git a/perlvars.h b/perlvars.h index 7bafa40..86a369e 100644 --- a/perlvars.h +++ b/perlvars.h @@ -10,9 +10,14 @@ /* =head1 Global Variables - These variables are global to an entire process. They are shared between -all interpreters and all threads in a process. +all interpreters and all threads in a process. Any variables not documented +here may be changed or removed without notice, so don't use them! +If you feel you really do need to use an unlisted variable, first send email to +L. It may be that +someone there will point out a way to accomplish what you need without using an +internal variable. But if not, you should get a go-ahead to document and then +use the variable. =cut */ diff --git a/perly.act b/perly.act index 70a1a4b..a636b74 100644 --- a/perly.act +++ b/perly.act @@ -8,7 +8,7 @@ case 2: #line 115 "perly.y" { parser->expect = XSTATE; - ;} + } break; case 3: @@ -17,14 +17,14 @@ case 2: newPROG(block_end((ps[(3) - (4)].val.ival),(ps[(4) - (4)].val.opval))); PL_compiling.cop_seq = 0; (yyval.ival) = 0; - ;} + } break; case 4: #line 125 "perly.y" { parser->expect = XTERM; - ;} + } break; case 5: @@ -32,14 +32,14 @@ case 2: { PL_eval_root = (ps[(3) - (3)].val.opval); (yyval.ival) = 0; - ;} + } break; case 6: #line 134 "perly.y" { parser->expect = XBLOCK; - ;} + } break; case 7: @@ -50,14 +50,14 @@ case 2: (yyval.ival) = 0; yyunlex(); parser->yychar = YYEOF; - ;} + } break; case 8: #line 146 "perly.y" { parser->expect = XSTATE; - ;} + } break; case 9: @@ -68,14 +68,14 @@ case 2: (yyval.ival) = 0; yyunlex(); parser->yychar = YYEOF; - ;} + } break; case 10: #line 158 "perly.y" { parser->expect = XSTATE; - ;} + } break; case 11: @@ -86,14 +86,14 @@ case 2: (yyval.ival) = 0; yyunlex(); parser->yychar = YYEOF; - ;} + } break; case 12: #line 170 "perly.y" { parser->expect = XSTATE; - ;} + } break; case 13: @@ -101,7 +101,7 @@ case 2: { PL_eval_root = (ps[(3) - (3)].val.opval); (yyval.ival) = 0; - ;} + } break; case 14: @@ -109,7 +109,7 @@ case 2: { if (parser->copline > (line_t)(ps[(1) - (4)].val.ival)) parser->copline = (line_t)(ps[(1) - (4)].val.ival); (yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval)); - ;} + } break; case 15: @@ -117,13 +117,13 @@ case 2: { if (parser->copline > (line_t)(ps[(1) - (7)].val.ival)) parser->copline = (line_t)(ps[(1) - (7)].val.ival); (yyval.opval) = block_end((ps[(2) - (7)].val.ival), (ps[(5) - (7)].val.opval)); - ;} + } break; case 16: #line 197 "perly.y" { (yyval.ival) = block_start(TRUE); - parser->parsed_sub = 0; ;} + parser->parsed_sub = 0; } break; case 17: @@ -131,18 +131,18 @@ case 2: { if (parser->copline > (line_t)(ps[(1) - (4)].val.ival)) parser->copline = (line_t)(ps[(1) - (4)].val.ival); (yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval)); - ;} + } break; case 18: #line 209 "perly.y" { (yyval.ival) = block_start(FALSE); - parser->parsed_sub = 0; ;} + parser->parsed_sub = 0; } break; case 19: #line 215 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} + { (yyval.opval) = (OP*)NULL; } break; case 20: @@ -151,12 +151,12 @@ case 2: PL_pad_reset_pending = TRUE; if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval)) PL_hints |= HINT_BLOCK_SCOPE; - ;} + } break; case 21: #line 226 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} + { (yyval.opval) = (OP*)NULL; } break; case 22: @@ -165,38 +165,38 @@ case 2: PL_pad_reset_pending = TRUE; if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval)) PL_hints |= HINT_BLOCK_SCOPE; - ;} + } break; case 23: #line 237 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval) ? newSTATEOP(0, NULL, (ps[(1) - (1)].val.opval)) : NULL; - ;} + } break; case 24: #line 241 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 25: #line 245 "perly.y" { (yyval.opval) = newSTATEOP(SVf_UTF8 * (ps[(1) - (2)].val.pval)[strlen((ps[(1) - (2)].val.pval))+1], (ps[(1) - (2)].val.pval), (ps[(2) - (2)].val.opval)); - ;} + } break; case 26: #line 249 "perly.y" { (yyval.opval) = newSTATEOP(SVf_UTF8 * (ps[(1) - (2)].val.pval)[strlen((ps[(1) - (2)].val.pval))+1], (ps[(1) - (2)].val.pval), (ps[(2) - (2)].val.opval)); - ;} + } break; case 27: #line 256 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 28: @@ -209,7 +209,7 @@ case 2: pad_add_weakref(fmtcv); } parser->parsed_sub = 1; - ;} + } break; case 29: @@ -234,7 +234,7 @@ case 2: CvCLONE_on(PL_compcv); parser->in_my = 0; parser->in_my_stash = NULL; - ;} + } break; case 30: @@ -248,7 +248,7 @@ case 2: (yyval.opval) = (OP*)NULL; intro_my(); parser->parsed_sub = 1; - ;} + } break; case 31: @@ -273,7 +273,7 @@ case 2: CvCLONE_on(PL_compcv); parser->in_my = 0; parser->in_my_stash = NULL; - ;} + } break; case 32: @@ -293,7 +293,7 @@ case 2: (yyval.opval) = (OP*)NULL; intro_my(); parser->parsed_sub = 1; - ;} + } break; case 33: @@ -303,12 +303,12 @@ case 2: if ((ps[(2) - (4)].val.opval)) package_version((ps[(2) - (4)].val.opval)); (yyval.opval) = (OP*)NULL; - ;} + } break; case 34: #line 347 "perly.y" - { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ ;} + { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ } break; case 35: @@ -318,7 +318,7 @@ case 2: utilize((ps[(1) - (7)].val.ival), (ps[(2) - (7)].val.ival), (ps[(4) - (7)].val.opval), (ps[(5) - (7)].val.opval), (ps[(6) - (7)].val.opval)); parser->parsed_sub = 1; (yyval.opval) = (OP*)NULL; - ;} + } break; case 36: @@ -327,7 +327,7 @@ case 2: (yyval.opval) = block_end((ps[(3) - (7)].val.ival), newCONDOP(0, (ps[(4) - (7)].val.opval), op_scope((ps[(6) - (7)].val.opval)), (ps[(7) - (7)].val.opval))); parser->copline = (line_t)(ps[(1) - (7)].val.ival); - ;} + } break; case 37: @@ -336,65 +336,59 @@ case 2: (yyval.opval) = block_end((ps[(3) - (7)].val.ival), newCONDOP(0, (ps[(4) - (7)].val.opval), op_scope((ps[(6) - (7)].val.opval)), (ps[(7) - (7)].val.opval))); parser->copline = (line_t)(ps[(1) - (7)].val.ival); - ;} + } break; case 38: #line 368 "perly.y" { - const PADOFFSET offset = pad_findmy_pvs("$_", 0); - (yyval.opval) = block_end((ps[(3) - (6)].val.ival), - newGIVENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)), - offset == NOT_IN_PAD - || PAD_COMPNAME_FLAGS_isOUR(offset) - ? 0 - : offset)); + (yyval.opval) = block_end((ps[(3) - (6)].val.ival), newGIVENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)), 0)); parser->copline = (line_t)(ps[(1) - (6)].val.ival); - ;} + } break; case 39: -#line 379 "perly.y" - { (yyval.opval) = block_end((ps[(3) - (6)].val.ival), newWHENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)))); ;} +#line 373 "perly.y" + { (yyval.opval) = block_end((ps[(3) - (6)].val.ival), newWHENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)))); } break; case 40: -#line 381 "perly.y" - { (yyval.opval) = newWHENOP(0, op_scope((ps[(2) - (2)].val.opval))); ;} +#line 375 "perly.y" + { (yyval.opval) = newWHENOP(0, op_scope((ps[(2) - (2)].val.opval))); } break; case 41: -#line 383 "perly.y" +#line 377 "perly.y" { (yyval.opval) = block_end((ps[(3) - (8)].val.ival), newWHILEOP(0, 1, (LOOP*)(OP*)NULL, (ps[(4) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval), (ps[(6) - (8)].val.ival))); parser->copline = (line_t)(ps[(1) - (8)].val.ival); - ;} + } break; case 42: -#line 390 "perly.y" +#line 384 "perly.y" { (yyval.opval) = block_end((ps[(3) - (8)].val.ival), newWHILEOP(0, 1, (LOOP*)(OP*)NULL, (ps[(4) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval), (ps[(6) - (8)].val.ival))); parser->copline = (line_t)(ps[(1) - (8)].val.ival); - ;} + } break; case 43: -#line 397 "perly.y" - { parser->expect = XTERM; ;} +#line 391 "perly.y" + { parser->expect = XTERM; } break; case 44: -#line 399 "perly.y" - { parser->expect = XTERM; ;} +#line 393 "perly.y" + { parser->expect = XTERM; } break; case 45: -#line 402 "perly.y" +#line 396 "perly.y" { OP *initop = (ps[(4) - (13)].val.opval); OP *forop = newWHILEOP(0, 1, (LOOP*)(OP*)NULL, @@ -408,33 +402,33 @@ case 2: PL_hints |= HINT_BLOCK_SCOPE; (yyval.opval) = block_end((ps[(3) - (13)].val.ival), forop); parser->copline = (line_t)(ps[(1) - (13)].val.ival); - ;} + } break; case 46: -#line 417 "perly.y" +#line 411 "perly.y" { (yyval.opval) = block_end((ps[(3) - (9)].val.ival), newFOROP(0, (ps[(4) - (9)].val.opval), (ps[(6) - (9)].val.opval), (ps[(8) - (9)].val.opval), (ps[(9) - (9)].val.opval))); parser->copline = (line_t)(ps[(1) - (9)].val.ival); - ;} + } break; case 47: -#line 422 "perly.y" +#line 416 "perly.y" { (yyval.opval) = block_end((ps[(4) - (8)].val.ival), newFOROP(0, op_lvalue((ps[(2) - (8)].val.opval), OP_ENTERLOOP), (ps[(5) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval))); parser->copline = (line_t)(ps[(1) - (8)].val.ival); - ;} + } break; case 48: -#line 428 "perly.y" - { parser->in_my = 0; (yyval.opval) = my((ps[(5) - (5)].val.opval)); ;} +#line 422 "perly.y" + { parser->in_my = 0; (yyval.opval) = my((ps[(5) - (5)].val.opval)); } break; case 49: -#line 430 "perly.y" +#line 424 "perly.y" { (yyval.opval) = block_end( (ps[(4) - (11)].val.ival), @@ -446,76 +440,76 @@ case 2: (ps[(8) - (11)].val.opval), (ps[(10) - (11)].val.opval), (ps[(11) - (11)].val.opval)) ); parser->copline = (line_t)(ps[(1) - (11)].val.ival); - ;} + } break; case 50: -#line 443 "perly.y" +#line 437 "perly.y" { (yyval.opval) = block_end((ps[(5) - (9)].val.ival), newFOROP( 0, op_lvalue(newUNOP(OP_REFGEN, 0, (ps[(3) - (9)].val.opval)), OP_ENTERLOOP), (ps[(6) - (9)].val.opval), (ps[(8) - (9)].val.opval), (ps[(9) - (9)].val.opval))); parser->copline = (line_t)(ps[(1) - (9)].val.ival); - ;} + } break; case 51: -#line 451 "perly.y" +#line 445 "perly.y" { (yyval.opval) = block_end((ps[(3) - (7)].val.ival), newFOROP(0, (OP*)NULL, (ps[(4) - (7)].val.opval), (ps[(6) - (7)].val.opval), (ps[(7) - (7)].val.opval))); parser->copline = (line_t)(ps[(1) - (7)].val.ival); - ;} + } break; case 52: -#line 457 "perly.y" +#line 451 "perly.y" { /* a block is a loop that happens once */ (yyval.opval) = newWHILEOP(0, 1, (LOOP*)(OP*)NULL, (OP*)NULL, (ps[(1) - (2)].val.opval), (ps[(2) - (2)].val.opval), 0); - ;} + } break; case 53: -#line 463 "perly.y" +#line 457 "perly.y" { package((ps[(3) - (5)].val.opval)); if ((ps[(2) - (5)].val.opval)) { package_version((ps[(2) - (5)].val.opval)); } - ;} + } break; case 54: -#line 470 "perly.y" +#line 464 "perly.y" { /* a block is a loop that happens once */ (yyval.opval) = newWHILEOP(0, 1, (LOOP*)(OP*)NULL, (OP*)NULL, block_end((ps[(5) - (8)].val.ival), (ps[(7) - (8)].val.opval)), (OP*)NULL, 0); if (parser->copline > (line_t)(ps[(4) - (8)].val.ival)) parser->copline = (line_t)(ps[(4) - (8)].val.ival); - ;} + } break; case 55: -#line 478 "perly.y" +#line 472 "perly.y" { (yyval.opval) = (ps[(1) - (2)].val.opval); - ;} + } break; case 56: -#line 482 "perly.y" +#line 476 "perly.y" { (yyval.opval) = (OP*)NULL; parser->copline = NOLINE; - ;} + } break; case 57: -#line 490 "perly.y" +#line 484 "perly.y" { OP *list; if ((ps[(2) - (2)].val.opval)) { OP *term = (ps[(2) - (2)].val.opval); @@ -529,192 +523,192 @@ case 2: else parser->copline--; (yyval.opval) = newSTATEOP(0, NULL, op_convert_list(OP_FORMLINE, 0, list)); - ;} + } break; case 58: -#line 507 "perly.y" - { (yyval.opval) = NULL; ;} +#line 501 "perly.y" + { (yyval.opval) = NULL; } break; case 59: -#line 509 "perly.y" - { (yyval.opval) = op_unscope((ps[(2) - (3)].val.opval)); ;} +#line 503 "perly.y" + { (yyval.opval) = op_unscope((ps[(2) - (3)].val.opval)); } break; case 60: -#line 514 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 508 "perly.y" + { (yyval.opval) = (OP*)NULL; } break; case 61: -#line 516 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 510 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 62: -#line 518 "perly.y" - { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;} +#line 512 "perly.y" + { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); } break; case 63: -#line 520 "perly.y" - { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;} +#line 514 "perly.y" + { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); } break; case 64: -#line 522 "perly.y" - { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[(3) - (3)].val.opval)), (ps[(1) - (3)].val.opval)); ;} +#line 516 "perly.y" + { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[(3) - (3)].val.opval)), (ps[(1) - (3)].val.opval)); } break; case 65: -#line 524 "perly.y" - { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;} +#line 518 "perly.y" + { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); } break; case 66: -#line 526 "perly.y" +#line 520 "perly.y" { (yyval.opval) = newFOROP(0, (OP*)NULL, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval), (OP*)NULL); - parser->copline = (line_t)(ps[(2) - (3)].val.ival); ;} + parser->copline = (line_t)(ps[(2) - (3)].val.ival); } break; case 67: -#line 529 "perly.y" - { (yyval.opval) = newWHENOP((ps[(3) - (3)].val.opval), op_scope((ps[(1) - (3)].val.opval))); ;} +#line 523 "perly.y" + { (yyval.opval) = newWHENOP((ps[(3) - (3)].val.opval), op_scope((ps[(1) - (3)].val.opval))); } break; case 68: -#line 534 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 528 "perly.y" + { (yyval.opval) = (OP*)NULL; } break; case 69: -#line 536 "perly.y" +#line 530 "perly.y" { ((ps[(2) - (2)].val.opval))->op_flags |= OPf_PARENS; (yyval.opval) = op_scope((ps[(2) - (2)].val.opval)); - ;} + } break; case 70: -#line 541 "perly.y" +#line 535 "perly.y" { parser->copline = (line_t)(ps[(1) - (6)].val.ival); (yyval.opval) = newCONDOP(0, newSTATEOP(OPf_SPECIAL,NULL,(ps[(3) - (6)].val.opval)), op_scope((ps[(5) - (6)].val.opval)), (ps[(6) - (6)].val.opval)); PL_hints |= HINT_BLOCK_SCOPE; - ;} + } break; case 71: -#line 551 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 545 "perly.y" + { (yyval.opval) = (OP*)NULL; } break; case 72: -#line 553 "perly.y" - { (yyval.opval) = op_scope((ps[(2) - (2)].val.opval)); ;} +#line 547 "perly.y" + { (yyval.opval) = op_scope((ps[(2) - (2)].val.opval)); } break; case 73: -#line 558 "perly.y" +#line 552 "perly.y" { (yyval.ival) = (PL_min_intro_pending && PL_max_intro_pending >= PL_min_intro_pending); - intro_my(); ;} + intro_my(); } break; case 74: -#line 564 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 558 "perly.y" + { (yyval.opval) = (OP*)NULL; } break; case 76: -#line 570 "perly.y" +#line 564 "perly.y" { YYSTYPE tmplval; (void)scan_num("1", &tmplval); - (yyval.opval) = tmplval.opval; ;} + (yyval.opval) = tmplval.opval; } break; case 78: -#line 578 "perly.y" - { (yyval.opval) = invert(scalar((ps[(1) - (1)].val.opval))); ;} +#line 572 "perly.y" + { (yyval.opval) = invert(scalar((ps[(1) - (1)].val.opval))); } break; case 79: -#line 583 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;} +#line 577 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); } break; case 80: -#line 587 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;} +#line 581 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); } break; case 81: -#line 591 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;} +#line 585 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); } break; case 82: -#line 594 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 588 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 83: -#line 595 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 589 "perly.y" + { (yyval.opval) = (OP*)NULL; } break; case 84: -#line 599 "perly.y" +#line 593 "perly.y" { (yyval.ival) = start_subparse(FALSE, 0); - SAVEFREESV(PL_compcv); ;} + SAVEFREESV(PL_compcv); } break; case 85: -#line 605 "perly.y" +#line 599 "perly.y" { (yyval.ival) = start_subparse(FALSE, CVf_ANON); - SAVEFREESV(PL_compcv); ;} + SAVEFREESV(PL_compcv); } break; case 86: -#line 610 "perly.y" +#line 604 "perly.y" { (yyval.ival) = start_subparse(TRUE, 0); - SAVEFREESV(PL_compcv); ;} + SAVEFREESV(PL_compcv); } break; case 89: -#line 621 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 615 "perly.y" + { (yyval.opval) = (OP*)NULL; } break; case 91: -#line 627 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 621 "perly.y" + { (yyval.opval) = (OP*)NULL; } break; case 92: -#line 629 "perly.y" - { (yyval.opval) = (ps[(2) - (2)].val.opval); ;} +#line 623 "perly.y" + { (yyval.opval) = (ps[(2) - (2)].val.opval); } break; case 93: -#line 631 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 625 "perly.y" + { (yyval.opval) = (OP*)NULL; } break; case 94: -#line 636 "perly.y" - { (yyval.opval) = (ps[(2) - (2)].val.opval); ;} +#line 630 "perly.y" + { (yyval.opval) = (ps[(2) - (2)].val.opval); } break; case 95: -#line 638 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 632 "perly.y" + { (yyval.opval) = (OP*)NULL; } break; case 96: -#line 643 "perly.y" +#line 637 "perly.y" { /* We shouldn't get here otherwise */ assert(FEATURE_SIGNATURES_IS_ENABLED); @@ -723,319 +717,319 @@ case 2: packWARN(WARN_EXPERIMENTAL__SIGNATURES), "The signatures feature is experimental"); (yyval.opval) = parse_subsignature(); - ;} + } break; case 97: -#line 653 "perly.y" +#line 647 "perly.y" { (yyval.opval) = op_append_list(OP_LINESEQ, (ps[(2) - (3)].val.opval), newSTATEOP(0, NULL, sawparens(newNULLLIST()))); parser->expect = XATTRBLOCK; - ;} + } break; case 99: -#line 662 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 656 "perly.y" + { (yyval.opval) = (OP*)NULL; } break; case 100: -#line 667 "perly.y" - { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;} +#line 661 "perly.y" + { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); } break; case 101: -#line 669 "perly.y" - { (yyval.opval) = newLOGOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;} +#line 663 "perly.y" + { (yyval.opval) = newLOGOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); } break; case 102: -#line 671 "perly.y" - { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;} +#line 665 "perly.y" + { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); } break; case 104: -#line 677 "perly.y" - { (yyval.opval) = (ps[(1) - (2)].val.opval); ;} +#line 671 "perly.y" + { (yyval.opval) = (ps[(1) - (2)].val.opval); } break; case 105: -#line 679 "perly.y" +#line 673 "perly.y" { OP* term = (ps[(3) - (3)].val.opval); (yyval.opval) = op_append_elem(OP_LIST, (ps[(1) - (3)].val.opval), term); - ;} + } break; case 107: -#line 688 "perly.y" +#line 682 "perly.y" { (yyval.opval) = op_convert_list((ps[(1) - (3)].val.ival), OPf_STACKED, op_prepend_elem(OP_LIST, newGVREF((ps[(1) - (3)].val.ival),(ps[(2) - (3)].val.opval)), (ps[(3) - (3)].val.opval)) ); - ;} + } break; case 108: -#line 692 "perly.y" +#line 686 "perly.y" { (yyval.opval) = op_convert_list((ps[(1) - (5)].val.ival), OPf_STACKED, op_prepend_elem(OP_LIST, newGVREF((ps[(1) - (5)].val.ival),(ps[(3) - (5)].val.opval)), (ps[(4) - (5)].val.opval)) ); - ;} + } break; case 109: -#line 696 "perly.y" +#line 690 "perly.y" { (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, scalar((ps[(1) - (6)].val.opval)), (ps[(5) - (6)].val.opval)), newMETHOP(OP_METHOD, 0, (ps[(3) - (6)].val.opval)))); - ;} + } break; case 110: -#line 702 "perly.y" +#line 696 "perly.y" { (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, scalar((ps[(1) - (3)].val.opval)), newMETHOP(OP_METHOD, 0, (ps[(3) - (3)].val.opval)))); - ;} + } break; case 111: -#line 707 "perly.y" +#line 701 "perly.y" { (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, (ps[(2) - (3)].val.opval), (ps[(3) - (3)].val.opval)), newMETHOP(OP_METHOD, 0, (ps[(1) - (3)].val.opval)))); - ;} + } break; case 112: -#line 713 "perly.y" +#line 707 "perly.y" { (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, (ps[(2) - (5)].val.opval), (ps[(4) - (5)].val.opval)), newMETHOP(OP_METHOD, 0, (ps[(1) - (5)].val.opval)))); - ;} + } break; case 113: -#line 719 "perly.y" - { (yyval.opval) = op_convert_list((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;} +#line 713 "perly.y" + { (yyval.opval) = op_convert_list((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); } break; case 114: -#line 721 "perly.y" - { (yyval.opval) = op_convert_list((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); ;} +#line 715 "perly.y" + { (yyval.opval) = op_convert_list((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); } break; case 115: -#line 723 "perly.y" +#line 717 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); - (yyval.opval) = newANONATTRSUB((ps[(2) - (3)].val.ival), 0, (OP*)NULL, (ps[(3) - (3)].val.opval)); ;} + (yyval.opval) = newANONATTRSUB((ps[(2) - (3)].val.ival), 0, (OP*)NULL, (ps[(3) - (3)].val.opval)); } break; case 116: -#line 726 "perly.y" +#line 720 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)), (ps[(1) - (5)].val.opval))); - ;} + } break; case 119: -#line 741 "perly.y" - { (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[(1) - (5)].val.opval), scalar((ps[(3) - (5)].val.opval))); ;} +#line 735 "perly.y" + { (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[(1) - (5)].val.opval), scalar((ps[(3) - (5)].val.opval))); } break; case 120: -#line 743 "perly.y" +#line 737 "perly.y" { (yyval.opval) = newBINOP(OP_AELEM, 0, oopsAV((ps[(1) - (4)].val.opval)), scalar((ps[(3) - (4)].val.opval))); - ;} + } break; case 121: -#line 746 "perly.y" +#line 740 "perly.y" { (yyval.opval) = newBINOP(OP_AELEM, 0, ref(newAVREF((ps[(1) - (5)].val.opval)),OP_RV2AV), scalar((ps[(4) - (5)].val.opval))); - ;} + } break; case 122: -#line 751 "perly.y" +#line 745 "perly.y" { (yyval.opval) = newBINOP(OP_AELEM, 0, ref(newAVREF((ps[(1) - (4)].val.opval)),OP_RV2AV), scalar((ps[(3) - (4)].val.opval))); - ;} + } break; case 123: -#line 756 "perly.y" +#line 750 "perly.y" { (yyval.opval) = newBINOP(OP_HELEM, 0, oopsHV((ps[(1) - (5)].val.opval)), jmaybe((ps[(3) - (5)].val.opval))); - ;} + } break; case 124: -#line 759 "perly.y" +#line 753 "perly.y" { (yyval.opval) = newBINOP(OP_HELEM, 0, ref(newHVREF((ps[(1) - (6)].val.opval)),OP_RV2HV), - jmaybe((ps[(4) - (6)].val.opval))); ;} + jmaybe((ps[(4) - (6)].val.opval))); } break; case 125: -#line 763 "perly.y" +#line 757 "perly.y" { (yyval.opval) = newBINOP(OP_HELEM, 0, ref(newHVREF((ps[(1) - (5)].val.opval)),OP_RV2HV), - jmaybe((ps[(3) - (5)].val.opval))); ;} + jmaybe((ps[(3) - (5)].val.opval))); } break; case 126: -#line 767 "perly.y" +#line 761 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, - newCVREF(0, scalar((ps[(1) - (4)].val.opval)))); ;} + newCVREF(0, scalar((ps[(1) - (4)].val.opval)))); } break; case 127: -#line 770 "perly.y" +#line 764 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, (ps[(4) - (5)].val.opval), - newCVREF(0, scalar((ps[(1) - (5)].val.opval))))); ;} + newCVREF(0, scalar((ps[(1) - (5)].val.opval))))); } break; case 128: -#line 775 "perly.y" +#line 769 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, (ps[(3) - (4)].val.opval), - newCVREF(0, scalar((ps[(1) - (4)].val.opval))))); ;} + newCVREF(0, scalar((ps[(1) - (4)].val.opval))))); } break; case 129: -#line 779 "perly.y" +#line 773 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, - newCVREF(0, scalar((ps[(1) - (3)].val.opval)))); ;} + newCVREF(0, scalar((ps[(1) - (3)].val.opval)))); } break; case 130: -#line 782 "perly.y" - { (yyval.opval) = newSLICEOP(0, (ps[(5) - (6)].val.opval), (ps[(2) - (6)].val.opval)); ;} +#line 776 "perly.y" + { (yyval.opval) = newSLICEOP(0, (ps[(5) - (6)].val.opval), (ps[(2) - (6)].val.opval)); } break; case 131: -#line 784 "perly.y" - { (yyval.opval) = newSLICEOP(0, (ps[(3) - (4)].val.opval), (ps[(1) - (4)].val.opval)); ;} +#line 778 "perly.y" + { (yyval.opval) = newSLICEOP(0, (ps[(3) - (4)].val.opval), (ps[(1) - (4)].val.opval)); } break; case 132: -#line 786 "perly.y" - { (yyval.opval) = newSLICEOP(0, (ps[(4) - (5)].val.opval), (OP*)NULL); ;} +#line 780 "perly.y" + { (yyval.opval) = newSLICEOP(0, (ps[(4) - (5)].val.opval), (OP*)NULL); } break; case 133: -#line 791 "perly.y" - { (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[(1) - (3)].val.opval), (ps[(2) - (3)].val.ival), (ps[(3) - (3)].val.opval)); ;} +#line 785 "perly.y" + { (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[(1) - (3)].val.opval), (ps[(2) - (3)].val.ival), (ps[(3) - (3)].val.opval)); } break; case 134: -#line 793 "perly.y" - { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} +#line 787 "perly.y" + { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } break; case 135: -#line 795 "perly.y" +#line 789 "perly.y" { if ((ps[(2) - (3)].val.ival) != OP_REPEAT) scalar((ps[(1) - (3)].val.opval)); (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), scalar((ps[(3) - (3)].val.opval))); - ;} + } break; case 136: -#line 800 "perly.y" - { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} +#line 794 "perly.y" + { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } break; case 137: -#line 802 "perly.y" - { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} +#line 796 "perly.y" + { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } break; case 138: -#line 804 "perly.y" - { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} +#line 798 "perly.y" + { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } break; case 139: -#line 806 "perly.y" - { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} +#line 800 "perly.y" + { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } break; case 140: -#line 808 "perly.y" - { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} +#line 802 "perly.y" + { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } break; case 141: -#line 810 "perly.y" - { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} +#line 804 "perly.y" + { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } break; case 142: -#line 812 "perly.y" - { (yyval.opval) = newRANGE((ps[(2) - (3)].val.ival), scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} +#line 806 "perly.y" + { (yyval.opval) = newRANGE((ps[(2) - (3)].val.ival), scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } break; case 143: -#line 814 "perly.y" - { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;} +#line 808 "perly.y" + { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); } break; case 144: -#line 816 "perly.y" - { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;} +#line 810 "perly.y" + { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); } break; case 145: -#line 818 "perly.y" - { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;} +#line 812 "perly.y" + { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); } break; case 146: -#line 820 "perly.y" - { (yyval.opval) = bind_match((ps[(2) - (3)].val.ival), (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;} +#line 814 "perly.y" + { (yyval.opval) = bind_match((ps[(2) - (3)].val.ival), (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); } break; case 147: -#line 825 "perly.y" - { (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[(2) - (2)].val.opval))); ;} +#line 819 "perly.y" + { (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[(2) - (2)].val.opval))); } break; case 148: -#line 827 "perly.y" - { (yyval.opval) = (ps[(2) - (2)].val.opval); ;} +#line 821 "perly.y" + { (yyval.opval) = (ps[(2) - (2)].val.opval); } break; case 149: -#line 830 "perly.y" - { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); ;} +#line 824 "perly.y" + { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); } break; case 150: -#line 832 "perly.y" - { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, scalar((ps[(2) - (2)].val.opval))); ;} +#line 826 "perly.y" + { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, scalar((ps[(2) - (2)].val.opval))); } break; case 151: -#line 834 "perly.y" +#line 828 "perly.y" { (yyval.opval) = newUNOP(OP_POSTINC, 0, - op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTINC)); ;} + op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTINC)); } break; case 152: -#line 837 "perly.y" +#line 831 "perly.y" { (yyval.opval) = newUNOP(OP_POSTDEC, 0, - op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTDEC));;} + op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTDEC));} break; case 153: -#line 840 "perly.y" +#line 834 "perly.y" { (yyval.opval) = op_convert_list(OP_JOIN, 0, op_append_elem( OP_LIST, @@ -1045,49 +1039,49 @@ case 2: )), (ps[(1) - (2)].val.opval) )); - ;} + } break; case 154: -#line 851 "perly.y" +#line 845 "perly.y" { (yyval.opval) = newUNOP(OP_PREINC, 0, - op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREINC)); ;} + op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREINC)); } break; case 155: -#line 854 "perly.y" +#line 848 "perly.y" { (yyval.opval) = newUNOP(OP_PREDEC, 0, - op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREDEC)); ;} + op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREDEC)); } break; case 156: -#line 861 "perly.y" - { (yyval.opval) = newANONLIST((ps[(2) - (3)].val.opval)); ;} +#line 855 "perly.y" + { (yyval.opval) = newANONLIST((ps[(2) - (3)].val.opval)); } break; case 157: -#line 863 "perly.y" - { (yyval.opval) = newANONLIST((OP*)NULL);;} +#line 857 "perly.y" + { (yyval.opval) = newANONLIST((OP*)NULL);} break; case 158: -#line 865 "perly.y" - { (yyval.opval) = newANONHASH((ps[(2) - (4)].val.opval)); ;} +#line 859 "perly.y" + { (yyval.opval) = newANONHASH((ps[(2) - (4)].val.opval)); } break; case 159: -#line 867 "perly.y" - { (yyval.opval) = newANONHASH((OP*)NULL); ;} +#line 861 "perly.y" + { (yyval.opval) = newANONHASH((OP*)NULL); } break; case 160: -#line 869 "perly.y" +#line 863 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); - (yyval.opval) = newANONATTRSUB((ps[(2) - (5)].val.ival), (ps[(3) - (5)].val.opval), (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)); ;} + (yyval.opval) = newANONATTRSUB((ps[(2) - (5)].val.ival), (ps[(3) - (5)].val.opval), (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)); } break; case 161: -#line 872 "perly.y" +#line 866 "perly.y" { OP *body; if (parser->copline > (line_t)(ps[(6) - (8)].val.ival)) @@ -1096,86 +1090,86 @@ case 2: op_append_list(OP_LINESEQ, (ps[(4) - (8)].val.opval), (ps[(7) - (8)].val.opval))); SvREFCNT_inc_simple_void(PL_compcv); (yyval.opval) = newANONATTRSUB((ps[(2) - (8)].val.ival), NULL, (ps[(5) - (8)].val.opval), body); - ;} + } break; case 162: -#line 886 "perly.y" - { (yyval.opval) = dofile((ps[(2) - (2)].val.opval), (ps[(1) - (2)].val.ival));;} +#line 880 "perly.y" + { (yyval.opval) = dofile((ps[(2) - (2)].val.opval), (ps[(1) - (2)].val.ival));} break; case 163: -#line 888 "perly.y" - { (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[(2) - (2)].val.opval)));;} +#line 882 "perly.y" + { (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[(2) - (2)].val.opval)));} break; case 168: -#line 896 "perly.y" - { (yyval.opval) = newCONDOP(0, (ps[(1) - (5)].val.opval), (ps[(3) - (5)].val.opval), (ps[(5) - (5)].val.opval)); ;} +#line 890 "perly.y" + { (yyval.opval) = newCONDOP(0, (ps[(1) - (5)].val.opval), (ps[(3) - (5)].val.opval), (ps[(5) - (5)].val.opval)); } break; case 169: -#line 898 "perly.y" - { (yyval.opval) = newUNOP(OP_REFGEN, 0, (ps[(2) - (2)].val.opval)); ;} +#line 892 "perly.y" + { (yyval.opval) = newUNOP(OP_REFGEN, 0, (ps[(2) - (2)].val.opval)); } break; case 170: -#line 900 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 894 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 171: -#line 902 "perly.y" - { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); ;} +#line 896 "perly.y" + { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); } break; case 172: -#line 904 "perly.y" - { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); ;} +#line 898 "perly.y" + { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); } break; case 173: -#line 906 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 900 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 174: -#line 908 "perly.y" - { (yyval.opval) = sawparens(newNULLLIST()); ;} +#line 902 "perly.y" + { (yyval.opval) = sawparens(newNULLLIST()); } break; case 175: -#line 910 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 904 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 176: -#line 912 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 906 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 177: -#line 914 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 908 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 178: -#line 916 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 910 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 179: -#line 918 "perly.y" - { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[(1) - (1)].val.opval), OP_AV2ARYLEN));;} +#line 912 "perly.y" + { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[(1) - (1)].val.opval), OP_AV2ARYLEN));} break; case 180: -#line 920 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 914 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 181: -#line 922 "perly.y" +#line 916 "perly.y" { (yyval.opval) = op_prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, @@ -1184,11 +1178,11 @@ case 2: if ((yyval.opval) && (ps[(1) - (4)].val.opval)) (yyval.opval)->op_private |= (ps[(1) - (4)].val.opval)->op_private & OPpSLICEWARNING; - ;} + } break; case 182: -#line 932 "perly.y" +#line 926 "perly.y" { (yyval.opval) = op_prepend_elem(OP_KVASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_KVASLICE, 0, @@ -1197,11 +1191,11 @@ case 2: if ((yyval.opval) && (ps[(1) - (4)].val.opval)) (yyval.opval)->op_private |= (ps[(1) - (4)].val.opval)->op_private & OPpSLICEWARNING; - ;} + } break; case 183: -#line 942 "perly.y" +#line 936 "perly.y" { (yyval.opval) = op_prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -1210,11 +1204,11 @@ case 2: if ((yyval.opval) && (ps[(1) - (5)].val.opval)) (yyval.opval)->op_private |= (ps[(1) - (5)].val.opval)->op_private & OPpSLICEWARNING; - ;} + } break; case 184: -#line 952 "perly.y" +#line 946 "perly.y" { (yyval.opval) = op_prepend_elem(OP_KVHSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_KVHSLICE, 0, @@ -1223,157 +1217,157 @@ case 2: if ((yyval.opval) && (ps[(1) - (5)].val.opval)) (yyval.opval)->op_private |= (ps[(1) - (5)].val.opval)->op_private & OPpSLICEWARNING; - ;} + } break; case 185: -#line 962 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 956 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 186: -#line 964 "perly.y" - { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[(1) - (1)].val.opval))); ;} +#line 958 "perly.y" + { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[(1) - (1)].val.opval))); } break; case 187: -#line 966 "perly.y" +#line 960 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (3)].val.opval))); - ;} + } break; case 188: -#line 969 "perly.y" +#line 963 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, (ps[(3) - (4)].val.opval), scalar((ps[(1) - (4)].val.opval)))); - ;} + } break; case 189: -#line 974 "perly.y" +#line 968 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, (ps[(3) - (3)].val.opval), scalar((ps[(2) - (3)].val.opval)))); - ;} + } break; case 190: -#line 978 "perly.y" - { (yyval.opval) = newSVREF((ps[(1) - (4)].val.opval)); ;} +#line 972 "perly.y" + { (yyval.opval) = newSVREF((ps[(1) - (4)].val.opval)); } break; case 191: -#line 980 "perly.y" - { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); ;} +#line 974 "perly.y" + { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); } break; case 192: -#line 982 "perly.y" - { (yyval.opval) = newHVREF((ps[(1) - (4)].val.opval)); ;} +#line 976 "perly.y" + { (yyval.opval) = newHVREF((ps[(1) - (4)].val.opval)); } break; case 193: -#line 984 "perly.y" +#line 978 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, - scalar(newCVREF((ps[(3) - (4)].val.ival),(ps[(1) - (4)].val.opval)))); ;} + scalar(newCVREF((ps[(3) - (4)].val.ival),(ps[(1) - (4)].val.opval)))); } break; case 194: -#line 987 "perly.y" - { (yyval.opval) = newGVREF(0,(ps[(1) - (4)].val.opval)); ;} +#line 981 "perly.y" + { (yyval.opval) = newGVREF(0,(ps[(1) - (4)].val.opval)); } break; case 195: -#line 989 "perly.y" +#line 983 "perly.y" { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), OPf_SPECIAL); - PL_hints |= HINT_BLOCK_SCOPE; ;} + PL_hints |= HINT_BLOCK_SCOPE; } break; case 196: -#line 992 "perly.y" - { (yyval.opval) = newLOOPEX((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); ;} +#line 986 "perly.y" + { (yyval.opval) = newLOOPEX((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); } break; case 197: -#line 994 "perly.y" - { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); ;} +#line 988 "perly.y" + { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); } break; case 198: -#line 996 "perly.y" - { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); ;} +#line 990 "perly.y" + { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); } break; case 199: -#line 998 "perly.y" - { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;} +#line 992 "perly.y" + { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); } break; case 200: -#line 1000 "perly.y" - { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;} +#line 994 "perly.y" + { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); } break; case 201: -#line 1002 "perly.y" - { (yyval.opval) = newOP(OP_REQUIRE, (ps[(1) - (1)].val.ival) ? OPf_SPECIAL : 0); ;} +#line 996 "perly.y" + { (yyval.opval) = newOP(OP_REQUIRE, (ps[(1) - (1)].val.ival) ? OPf_SPECIAL : 0); } break; case 202: -#line 1004 "perly.y" - { (yyval.opval) = newUNOP(OP_REQUIRE, (ps[(1) - (2)].val.ival) ? OPf_SPECIAL : 0, (ps[(2) - (2)].val.opval)); ;} +#line 998 "perly.y" + { (yyval.opval) = newUNOP(OP_REQUIRE, (ps[(1) - (2)].val.ival) ? OPf_SPECIAL : 0, (ps[(2) - (2)].val.opval)); } break; case 203: -#line 1006 "perly.y" - { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;} +#line 1000 "perly.y" + { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); } break; case 204: -#line 1008 "perly.y" +#line 1002 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, (ps[(2) - (2)].val.opval), scalar((ps[(1) - (2)].val.opval)))); ;} + op_append_elem(OP_LIST, (ps[(2) - (2)].val.opval), scalar((ps[(1) - (2)].val.opval)))); } break; case 205: -#line 1011 "perly.y" - { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); ;} +#line 1005 "perly.y" + { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); } break; case 206: -#line 1013 "perly.y" - { (yyval.opval) = newOP((ps[(1) - (3)].val.ival), 0);;} +#line 1007 "perly.y" + { (yyval.opval) = newOP((ps[(1) - (3)].val.ival), 0);} break; case 207: -#line 1015 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 1009 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 208: -#line 1017 "perly.y" - { (yyval.opval) = (ps[(1) - (3)].val.opval); ;} +#line 1011 "perly.y" + { (yyval.opval) = (ps[(1) - (3)].val.opval); } break; case 209: -#line 1019 "perly.y" - { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;} +#line 1013 "perly.y" + { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); } break; case 210: -#line 1021 "perly.y" +#line 1015 "perly.y" { (yyval.opval) = ((ps[(1) - (3)].val.ival) == OP_NOT) ? newUNOP((ps[(1) - (3)].val.ival), 0, newSVOP(OP_CONST, 0, newSViv(0))) - : newOP((ps[(1) - (3)].val.ival), OPf_SPECIAL); ;} + : newOP((ps[(1) - (3)].val.ival), OPf_SPECIAL); } break; case 211: -#line 1025 "perly.y" - { (yyval.opval) = newUNOP((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); ;} +#line 1019 "perly.y" + { (yyval.opval) = newUNOP((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); } break; case 212: -#line 1027 "perly.y" +#line 1021 "perly.y" { if ( (ps[(1) - (1)].val.opval)->op_type != OP_TRANS && (ps[(1) - (1)].val.opval)->op_type != OP_TRANSR @@ -1383,173 +1377,170 @@ case 2: SAVEFREESV(PL_compcv); } else (yyval.ival) = 0; - ;} + } break; case 213: -#line 1038 "perly.y" - { (yyval.opval) = pmruntime((ps[(1) - (6)].val.opval), (ps[(4) - (6)].val.opval), (ps[(5) - (6)].val.opval), 1, (ps[(2) - (6)].val.ival)); ;} +#line 1032 "perly.y" + { (yyval.opval) = pmruntime((ps[(1) - (6)].val.opval), (ps[(4) - (6)].val.opval), (ps[(5) - (6)].val.opval), 1, (ps[(2) - (6)].val.ival)); } break; case 216: -#line 1042 "perly.y" +#line 1036 "perly.y" { (yyval.opval) = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0), newSVOP(OP_CONST, 0, newSVpvs("Unimplemented"))); - ;} + } break; case 218: -#line 1051 "perly.y" - { (yyval.opval) = my_attrs((ps[(2) - (3)].val.opval),(ps[(3) - (3)].val.opval)); ;} +#line 1045 "perly.y" + { (yyval.opval) = my_attrs((ps[(2) - (3)].val.opval),(ps[(3) - (3)].val.opval)); } break; case 219: -#line 1053 "perly.y" - { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); ;} +#line 1047 "perly.y" + { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); } break; case 220: -#line 1058 "perly.y" - { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); ;} +#line 1052 "perly.y" + { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); } break; case 221: -#line 1060 "perly.y" - { (yyval.opval) = sawparens(newNULLLIST()); ;} +#line 1054 "perly.y" + { (yyval.opval) = sawparens(newNULLLIST()); } break; case 222: -#line 1063 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 1057 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 223: -#line 1065 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 1059 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 224: -#line 1067 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 1061 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 225: -#line 1072 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 1066 "perly.y" + { (yyval.opval) = (OP*)NULL; } break; case 226: -#line 1074 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 1068 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 227: -#line 1078 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 1072 "perly.y" + { (yyval.opval) = (OP*)NULL; } break; case 228: -#line 1080 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 1074 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; case 229: -#line 1084 "perly.y" - { (yyval.opval) = (OP*)NULL; ;} +#line 1078 "perly.y" + { (yyval.opval) = (OP*)NULL; } break; case 230: -#line 1086 "perly.y" - { (yyval.opval) = (ps[(2) - (2)].val.opval); ;} +#line 1080 "perly.y" + { (yyval.opval) = (ps[(2) - (2)].val.opval); } break; case 231: -#line 1092 "perly.y" - { parser->in_my = 0; (yyval.opval) = my((ps[(1) - (1)].val.opval)); ;} +#line 1086 "perly.y" + { parser->in_my = 0; (yyval.opval) = my((ps[(1) - (1)].val.opval)); } break; case 237: -#line 1105 "perly.y" - { (yyval.opval) = newCVREF((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); ;} +#line 1099 "perly.y" + { (yyval.opval) = newCVREF((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); } break; case 238: -#line 1109 "perly.y" - { (yyval.opval) = newSVREF((ps[(2) - (2)].val.opval)); ;} +#line 1103 "perly.y" + { (yyval.opval) = newSVREF((ps[(2) - (2)].val.opval)); } break; case 239: -#line 1113 "perly.y" +#line 1107 "perly.y" { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival); - ;} + } break; case 240: -#line 1119 "perly.y" +#line 1113 "perly.y" { (yyval.opval) = newHVREF((ps[(2) - (2)].val.opval)); if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival); - ;} + } break; case 241: -#line 1125 "perly.y" - { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); ;} +#line 1119 "perly.y" + { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); } break; case 242: -#line 1127 "perly.y" - { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); ;} +#line 1121 "perly.y" + { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); } break; case 243: -#line 1131 "perly.y" - { (yyval.opval) = newGVREF(0,(ps[(2) - (2)].val.opval)); ;} +#line 1125 "perly.y" + { (yyval.opval) = newGVREF(0,(ps[(2) - (2)].val.opval)); } break; case 245: -#line 1136 "perly.y" - { (yyval.opval) = newAVREF((ps[(1) - (3)].val.opval)); ;} +#line 1130 "perly.y" + { (yyval.opval) = newAVREF((ps[(1) - (3)].val.opval)); } break; case 247: -#line 1141 "perly.y" - { (yyval.opval) = newHVREF((ps[(1) - (3)].val.opval)); ;} +#line 1135 "perly.y" + { (yyval.opval) = newHVREF((ps[(1) - (3)].val.opval)); } break; case 249: -#line 1146 "perly.y" - { (yyval.opval) = newGVREF(0,(ps[(1) - (3)].val.opval)); ;} +#line 1140 "perly.y" + { (yyval.opval) = newGVREF(0,(ps[(1) - (3)].val.opval)); } break; case 250: -#line 1151 "perly.y" - { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;} +#line 1145 "perly.y" + { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); } break; case 251: -#line 1153 "perly.y" - { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;} +#line 1147 "perly.y" + { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); } break; case 252: -#line 1155 "perly.y" - { (yyval.opval) = op_scope((ps[(1) - (1)].val.opval)); ;} +#line 1149 "perly.y" + { (yyval.opval) = op_scope((ps[(1) - (1)].val.opval)); } break; case 253: -#line 1158 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} +#line 1152 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); } break; - -/* Line 1267 of yacc.c. */ - default: break; /* Generated from: - * e2ef3626c25dd92c66987e4c2f707e7f194c2bd5df74da27c51df206d9809412 perly.y + * a0bc910627eeeffe8245b9a63dd97238e2e6b27b544be36b37d078cf6aba699b perly.y * d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl * ex: set ro: */ diff --git a/perly.h b/perly.h index db139d8..1170e9c 100644 --- a/perly.h +++ b/perly.h @@ -5,27 +5,24 @@ */ #ifdef PERL_CORE -/* A Bison parser, made by GNU Bison 2.3. */ +/* A Bison parser, made by GNU Bison 2.7. */ -/* Skeleton interface for Bison's Yacc-like parsers in C - - Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006 - Free Software Foundation, Inc. - - This program is free software; you can redistribute it and/or modify +/* Bison interface for Yacc-like parsers in C + + Copyright (C) 1984, 1989-1990, 2000-2012 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2, or (at your option) - any later version. - + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. - + You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, - Boston, MA 02110-1301, USA. */ + along with this program. If not, see . */ /* As a special exception, you may create a larger work that contains part or all of the Bison parser skeleton and distribute that work @@ -36,10 +33,18 @@ special exception, which will cause the skeleton and the resulting Bison output files to be licensed under the GNU General Public License without this special exception. - + This special exception was added by the Free Software Foundation in version 2.2 of Bison. */ +/* Enabling traces. */ +#ifndef YYDEBUG +# define YYDEBUG 0 +#endif +#if YYDEBUG +extern int yydebug; +#endif + /* Tokens. */ #ifndef YYTOKENTYPE # define YYTOKENTYPE @@ -128,6 +133,7 @@ ARROW = 337 }; #endif + /* Tokens. */ #define GRAMPROG 258 #define GRAMEXPR 259 @@ -211,8 +217,6 @@ #define ARROW 337 - - #ifdef PERL_IN_TOKE_C static bool S_is_opval_token(int type) { @@ -239,23 +243,39 @@ S_is_opval_token(int type) { #if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED typedef union YYSTYPE { +/* Line 2058 of yacc.c */ + I32 ival; /* __DEFAULT__ (marker for regen_perly.pl; must always be 1st union member) */ char *pval; OP *opval; GV *gvval; -} -/* Line 1529 of yacc.c. */ - YYSTYPE; + + +/* Line 2058 of yacc.c */ +} YYSTYPE; +# define YYSTYPE_IS_TRIVIAL 1 # define yystype YYSTYPE /* obsolescent; will be withdrawn */ # define YYSTYPE_IS_DECLARED 1 -# define YYSTYPE_IS_TRIVIAL 1 #endif +#ifdef YYPARSE_PARAM +#if defined __STDC__ || defined __cplusplus +int yyparse (void *YYPARSE_PARAM); +#else +int yyparse (); +#endif +#else /* ! YYPARSE_PARAM */ +#if defined __STDC__ || defined __cplusplus +int yyparse (void); +#else +int yyparse (); +#endif +#endif /* ! YYPARSE_PARAM */ /* Generated from: - * e2ef3626c25dd92c66987e4c2f707e7f194c2bd5df74da27c51df206d9809412 perly.y + * a0bc910627eeeffe8245b9a63dd97238e2e6b27b544be36b37d078cf6aba699b perly.y * d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl * ex: set ro: */ diff --git a/perly.tab b/perly.tab index 8ef9129..9f56916 100644 --- a/perly.tab +++ b/perly.tab @@ -196,33 +196,33 @@ static const yytype_uint16 yyrline[] = 0, 115, 115, 114, 125, 124, 134, 133, 146, 145, 158, 157, 170, 169, 181, 189, 197, 201, 209, 215, 216, 226, 227, 236, 240, 244, 248, 255, 257, 268, - 267, 301, 300, 339, 347, 346, 355, 361, 367, 378, - 380, 382, 389, 397, 399, 396, 416, 421, 428, 427, - 442, 450, 456, 463, 462, 477, 481, 489, 507, 508, - 513, 515, 517, 519, 521, 523, 525, 528, 534, 535, - 540, 551, 552, 558, 564, 565, 570, 573, 577, 582, - 586, 590, 594, 595, 599, 605, 610, 615, 616, 621, - 622, 627, 628, 630, 635, 637, 643, 642, 661, 662, - 666, 668, 670, 672, 676, 678, 683, 687, 691, 695, - 701, 706, 712, 718, 720, 723, 722, 733, 734, 738, - 742, 745, 750, 755, 758, 762, 766, 769, 774, 778, - 781, 783, 785, 790, 792, 794, 799, 801, 803, 805, - 807, 809, 811, 813, 815, 817, 819, 824, 826, 829, - 831, 833, 836, 839, 850, 853, 860, 862, 864, 866, - 868, 871, 885, 887, 891, 892, 893, 894, 895, 897, - 899, 901, 903, 905, 907, 909, 911, 913, 915, 917, - 919, 921, 931, 941, 951, 961, 963, 965, 968, 973, - 977, 979, 981, 983, 986, 988, 991, 993, 995, 997, - 999, 1001, 1003, 1005, 1007, 1010, 1012, 1014, 1016, 1018, - 1020, 1024, 1027, 1026, 1039, 1040, 1041, 1046, 1050, 1052, - 1057, 1059, 1062, 1064, 1066, 1071, 1073, 1078, 1079, 1084, - 1085, 1091, 1095, 1096, 1097, 1100, 1101, 1104, 1108, 1112, - 1118, 1124, 1126, 1130, 1134, 1135, 1139, 1140, 1144, 1145, - 1150, 1152, 1154, 1157 + 267, 301, 300, 339, 347, 346, 355, 361, 367, 372, + 374, 376, 383, 391, 393, 390, 410, 415, 422, 421, + 436, 444, 450, 457, 456, 471, 475, 483, 501, 502, + 507, 509, 511, 513, 515, 517, 519, 522, 528, 529, + 534, 545, 546, 552, 558, 559, 564, 567, 571, 576, + 580, 584, 588, 589, 593, 599, 604, 609, 610, 615, + 616, 621, 622, 624, 629, 631, 637, 636, 655, 656, + 660, 662, 664, 666, 670, 672, 677, 681, 685, 689, + 695, 700, 706, 712, 714, 717, 716, 727, 728, 732, + 736, 739, 744, 749, 752, 756, 760, 763, 768, 772, + 775, 777, 779, 784, 786, 788, 793, 795, 797, 799, + 801, 803, 805, 807, 809, 811, 813, 818, 820, 823, + 825, 827, 830, 833, 844, 847, 854, 856, 858, 860, + 862, 865, 879, 881, 885, 886, 887, 888, 889, 891, + 893, 895, 897, 899, 901, 903, 905, 907, 909, 911, + 913, 915, 925, 935, 945, 955, 957, 959, 962, 967, + 971, 973, 975, 977, 980, 982, 985, 987, 989, 991, + 993, 995, 997, 999, 1001, 1004, 1006, 1008, 1010, 1012, + 1014, 1018, 1021, 1020, 1033, 1034, 1035, 1040, 1044, 1046, + 1051, 1053, 1056, 1058, 1060, 1065, 1067, 1072, 1073, 1078, + 1079, 1085, 1089, 1090, 1091, 1094, 1095, 1098, 1102, 1106, + 1112, 1118, 1120, 1124, 1128, 1129, 1133, 1134, 1138, 1139, + 1144, 1146, 1148, 1151 }; #endif -#if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE +#if YYDEBUG || YYERROR_VERBOSE || 0 /* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. First, the terminals, then, starting at YYNTOKENS, nonterminals. */ static const char *const yytname[] = @@ -242,18 +242,18 @@ static const char *const yytname[] = "BITOROP", "BITANDOP", "SHIFTOP", "MATCHOP", "'!'", "'~'", "REFGEN", "UMINUS", "POWOP", "POSTJOIN", "POSTDEC", "POSTINC", "PREDEC", "PREINC", "ARROW", "')'", "'('", "';'", "'$'", "'*'", "'/'", "$accept", "grammar", - "@1", "@2", "@3", "@4", "@5", "@6", "block", "formblock", "remember", - "mblock", "mremember", "stmtseq", "formstmtseq", "fullstmt", - "labfullstmt", "barestmt", "@7", "@8", "@9", "@10", "@11", "@12", "@13", - "formline", "formarg", "sideff", "else", "cont", "mintro", "nexpr", - "texpr", "iexpr", "mexpr", "mnexpr", "miexpr", "formname", "startsub", - "startanonsub", "startformsub", "subname", "proto", "subattrlist", - "myattrlist", "subsignature", "@14", "optsubbody", "expr", "listexpr", - "listop", "@15", "method", "subscripted", "termbinop", "termunop", - "anonymous", "termdo", "term", "@16", "myattrterm", "myterm", + "$@1", "$@2", "$@3", "$@4", "$@5", "$@6", "block", "formblock", + "remember", "mblock", "mremember", "stmtseq", "formstmtseq", "fullstmt", + "labfullstmt", "barestmt", "$@7", "$@8", "$@9", "$@10", "$@11", "@12", + "$@13", "formline", "formarg", "sideff", "else", "cont", "mintro", + "nexpr", "texpr", "iexpr", "mexpr", "mnexpr", "miexpr", "formname", + "startsub", "startanonsub", "startformsub", "subname", "proto", + "subattrlist", "myattrlist", "subsignature", "@14", "optsubbody", "expr", + "listexpr", "listop", "@15", "method", "subscripted", "termbinop", + "termunop", "anonymous", "termdo", "term", "@16", "myattrterm", "myterm", "optlistexpr", "optexpr", "optrepl", "my_scalar", "my_var", "refgen_topic", "amper", "scalar", "ary", "hsh", "arylen", "star", - "sliceme", "kvslice", "gelem", "indirob", 0 + "sliceme", "kvslice", "gelem", "indirob", YY_NULL }; #endif @@ -338,8 +338,8 @@ static const yytype_uint8 yyr2[] = 1, 1, 1, 1 }; -/* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state - STATE-NUM when YYTABLE doesn't specify something else to do. Zero +/* YYDEFACT[STATE-NAME] -- Default reduction number in state STATE-NUM. + Performed when YYTABLE doesn't specify something else to do. Zero means the default is an error. */ static const yytype_uint8 yydefact[] = { @@ -482,8 +482,7 @@ static const yytype_int16 yypgoto[] = /* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If positive, shift that token. If negative, reduce the rule which - number is the opposite. If zero, do what YYDEFACT says. - If YYTABLE_NINF, syntax error. */ + number is the opposite. If YYTABLE_NINF, syntax error. */ #define YYTABLE_NINF -249 static const yytype_int16 yytable[] = { @@ -783,6 +782,12 @@ static const yytype_int16 yytable[] = 184 }; +#define yypact_value_is_default(Yystate) \ + (!!((Yystate) == (-402))) + +#define yytable_value_is_error(Yytable_value) \ + (!!((Yytable_value) == (-249))) + static const yytype_int16 yycheck[] = { 15, 308, 9, 325, 9, 40, 46, 46, 115, 9, @@ -1160,21 +1165,21 @@ static const toketypes yy_type_tab[] = toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, - toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_ival, - toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, - toketype_opval, toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, - toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, - toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, - toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_opval, - toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, - toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, + toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, + toketype_ival, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, + toketype_opval, toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, + toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, + toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, + toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, + toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, + toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval }; /* Generated from: - * e2ef3626c25dd92c66987e4c2f707e7f194c2bd5df74da27c51df206d9809412 perly.y + * a0bc910627eeeffe8245b9a63dd97238e2e6b27b544be36b37d078cf6aba699b perly.y * d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl * ex: set ro: */ diff --git a/perly.y b/perly.y index 4b73977..b3be67d 100644 --- a/perly.y +++ b/perly.y @@ -366,13 +366,7 @@ barestmt: PLUGSTMT } | GIVEN '(' remember mexpr ')' mblock { - const PADOFFSET offset = pad_findmy_pvs("$_", 0); - $$ = block_end($3, - newGIVENOP($4, op_scope($6), - offset == NOT_IN_PAD - || PAD_COMPNAME_FLAGS_isOUR(offset) - ? 0 - : offset)); + $$ = block_end($3, newGIVENOP($4, op_scope($6), 0)); parser->copline = (line_t)$1; } | WHEN '(' remember mexpr ')' mblock diff --git a/plan9/config.plan9 b/plan9/config.plan9 index ca40598..77f1ea3 100644 --- a/plan9/config.plan9 +++ b/plan9/config.plan9 @@ -1478,24 +1478,12 @@ */ /*#define HAS_FREXPL / **/ -/* HAS_STRUCT_FS_DATA: - * This symbol, if defined, indicates that the struct fs_data - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_FS_DATA / **/ - /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO / **/ -/* HAS_FSTATFS: - * This symbol, if defined, indicates that the fstatfs routine is - * available to stat filesystems by file descriptors. - */ -/*#define HAS_FSTATFS / **/ - /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to @@ -1538,12 +1526,6 @@ */ /*#define HAS_GETESPWNAM / **/ -/* HAS_GETFSSTAT: - * This symbol, if defined, indicates that the getfsstat routine is - * available to stat filesystems in bulk. - */ -/*#define HAS_GETFSSTAT / **/ - /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. @@ -1663,18 +1645,6 @@ /*#define HAS_GETLOGIN_R / **/ #define GETLOGIN_R_PROTO 0 /**/ -/* HAS_GETMNT: - * This symbol, if defined, indicates that the getmnt routine is - * available to get filesystem mount info by filename. - */ -/*#define HAS_GETMNT / **/ - -/* HAS_GETMNTENT: - * This symbol, if defined, indicates that the getmntent routine is - * available to iterate through mounted file systems to get their info. - */ -/*#define HAS_GETMNTENT / **/ - /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. @@ -1862,11 +1832,6 @@ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif -/* HAS_HASMNTOPT: - * This symbol, if defined, indicates that the hasmntopt routine is - * available to query the mount options of file systems. - */ -/*#define HAS_HASMNTOPT / **/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and @@ -2055,15 +2020,7 @@ * available to split a long double x into a fractional part f and * an integer part i such that |f| < 1.0 and (f + i) = x. */ -/* HAS_MODFL_POW32_BUG: - * This symbol, if defined, indicates that the modfl routine is - * broken for long doubles >= pow(2, 32). - * For example from 4294967303.150000 one would get 4294967302.000000 - * and 1.150000. The bug has been seen in certain versions of glibc, - * release 2.2.2 is known to be okay. - */ /*#define HAS_MODFL / **/ -/*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is @@ -2384,44 +2341,8 @@ * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ -/* HAS_MSG_CTRUNC: - * This symbol, if defined, indicates that the MSG_CTRUNC is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_DONTROUTE: - * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_OOB: - * This symbol, if defined, indicates that the MSG_OOB is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PEEK: - * This symbol, if defined, indicates that the MSG_PEEK is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PROXY: - * This symbol, if defined, indicates that the MSG_PROXY is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_SCM_RIGHTS: - * This symbol, if defined, indicates that the SCM_RIGHTS is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ #define HAS_SOCKET /**/ #define HAS_SOCKETPAIR /**/ -/*#define HAS_MSG_CTRUNC / **/ -/*#define HAS_MSG_DONTROUTE / **/ -/*#define HAS_MSG_OOB / **/ -/*#define HAS_MSG_PEEK / **/ -/*#define HAS_MSG_PROXY / **/ -/*#define HAS_SCM_RIGHTS / **/ /* HAS_SOCKS5_INIT: * This symbol, if defined, indicates that the socks5_init routine is @@ -2469,29 +2390,6 @@ /*#define USE_STAT_BLOCKS / **/ #endif -/* HAS_STRUCT_STATFS_F_FLAGS: - * This symbol, if defined, indicates that the struct statfs - * does have the f_flags member containing the mount flags of - * the filesystem containing the file. - * This kind of struct statfs is coming from (BSD 4.3), - * not from (SYSV). Older BSDs (like Ultrix) do not - * have statfs() and struct statfs, they have ustat() and getmnt() - * with struct ustat and struct fs_data. - */ -/*#define HAS_STRUCT_STATFS_F_FLAGS / **/ - -/* HAS_STRUCT_STATFS: - * This symbol, if defined, indicates that the struct statfs - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_STATFS / **/ - -/* HAS_FSTATVFS: - * This symbol, if defined, indicates that the fstatvfs routine is - * available to stat filesystems by file descriptors. - */ -/*#define HAS_FSTATVFS / **/ - /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) * of the stdio FILE structure can be used to access the stdio buffer @@ -2704,12 +2602,6 @@ */ /*#define HAS_UNORDERED / **/ -/* HAS_USTAT: - * This symbol, if defined, indicates that the ustat system call is - * available to query file system statistics by dev_t. - */ -/*#define HAS_USTAT / **/ - /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ @@ -2891,12 +2783,6 @@ */ /*#define I_MACH_CTHREADS / **/ -/* I_MNTENT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_MNTENT / **/ - /* I_NETDB: * This symbol, if defined, indicates that exists and * should be included. @@ -3003,23 +2889,6 @@ */ /*#define I_SYSMODE / **/ -/* I_SYS_MOUNT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_MOUNT / **/ - -/* I_SYS_STATFS: - * This symbol, if defined, indicates that exists. - */ -/*#define I_SYS_STATFS / **/ - -/* I_SYS_STATVFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_STATVFS / **/ - /* I_SYSUIO: * This symbol, if defined, indicates that exists and * should be included. @@ -3032,12 +2901,6 @@ */ #define I_SYSUTSNAME /**/ -/* I_SYS_VFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_VFS / **/ - /* Plan 9: P9 has both and */ /* I_TIME: * This symbol, if defined, indicates to the C program that it should @@ -3063,12 +2926,6 @@ /*#define I_SYS_TIME_KERNEL / **/ /*#define HAS_TM_TM_ZONE / **/ -/* I_USTAT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_USTAT / **/ - /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over * which perl.c:incpush() and lib/lib.pm will automatically @@ -3373,8 +3230,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "/sys/lib/perl/5.23.3" /**/ -#define PRIVLIB_EXP "/sys/lib/perl/5.23.3" /**/ +#define PRIVLIB "/sys/lib/perl/5.23.4" /**/ +#define PRIVLIB_EXP "/sys/lib/perl/5.23.4" /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor @@ -3501,9 +3358,9 @@ * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ -#define SITELIB "/sys/lib/perl/5.23.3/site_perl" /**/ -#define SITELIB_EXP "/sys/lib/perl/5.23.3/site_perl" /**/ -#define SITELIB_STEM "/sys/lib/perl/5.23.3/site_perl" /**/ +#define SITELIB "/sys/lib/perl/5.23.4/site_perl" /**/ +#define SITELIB_EXP "/sys/lib/perl/5.23.4/site_perl" /**/ +#define SITELIB_STEM "/sys/lib/perl/5.23.4/site_perl" /**/ /* Size_t_size: * This symbol holds the size of a Size_t in bytes. diff --git a/plan9/config_h.sample b/plan9/config_h.sample index 8b41865..c89ab71 100644 --- a/plan9/config_h.sample +++ b/plan9/config_h.sample @@ -1431,24 +1431,12 @@ */ /*#define HAS_FREXPL / **/ -/* HAS_STRUCT_FS_DATA: - * This symbol, if defined, indicates that the struct fs_data - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_FS_DATA / **/ - /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO / **/ -/* HAS_FSTATFS: - * This symbol, if defined, indicates that the fstatfs routine is - * available to stat filesystems by file descriptors. - */ -/*#define HAS_FSTATFS / **/ - /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to @@ -1491,12 +1479,6 @@ */ /*#define HAS_GETESPWNAM / **/ -/* HAS_GETFSSTAT: - * This symbol, if defined, indicates that the getfsstat routine is - * available to stat filesystems in bulk. - */ -/*#define HAS_GETFSSTAT / **/ - /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. @@ -1616,18 +1598,6 @@ /*#define HAS_GETLOGIN_R / **/ #define GETLOGIN_R_PROTO 0 /**/ -/* HAS_GETMNT: - * This symbol, if defined, indicates that the getmnt routine is - * available to get filesystem mount info by filename. - */ -/*#define HAS_GETMNT / **/ - -/* HAS_GETMNTENT: - * This symbol, if defined, indicates that the getmntent routine is - * available to iterate through mounted file systems to get their info. - */ -/*#define HAS_GETMNTENT / **/ - /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. @@ -1815,11 +1785,6 @@ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif -/* HAS_HASMNTOPT: - * This symbol, if defined, indicates that the hasmntopt routine is - * available to query the mount options of file systems. - */ -/*#define HAS_HASMNTOPT / **/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and @@ -2008,15 +1973,7 @@ * available to split a long double x into a fractional part f and * an integer part i such that |f| < 1.0 and (f + i) = x. */ -/* HAS_MODFL_POW32_BUG: - * This symbol, if defined, indicates that the modfl routine is - * broken for long doubles >= pow(2, 32). - * For example from 4294967303.150000 one would get 4294967302.000000 - * and 1.150000. The bug has been seen in certain versions of glibc, - * release 2.2.2 is known to be okay. - */ /*#define HAS_MODFL / **/ -/*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is @@ -2316,44 +2273,8 @@ * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ -/* HAS_MSG_CTRUNC: - * This symbol, if defined, indicates that the MSG_CTRUNC is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_DONTROUTE: - * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_OOB: - * This symbol, if defined, indicates that the MSG_OOB is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PEEK: - * This symbol, if defined, indicates that the MSG_PEEK is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PROXY: - * This symbol, if defined, indicates that the MSG_PROXY is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_SCM_RIGHTS: - * This symbol, if defined, indicates that the SCM_RIGHTS is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ #define HAS_SOCKET /**/ #define HAS_SOCKETPAIR /**/ -/*#define HAS_MSG_CTRUNC / **/ -/*#define HAS_MSG_DONTROUTE / **/ -/*#define HAS_MSG_OOB / **/ -/*#define HAS_MSG_PEEK / **/ -/*#define HAS_MSG_PROXY / **/ -/*#define HAS_SCM_RIGHTS / **/ /* HAS_SOCKS5_INIT: * This symbol, if defined, indicates that the socks5_init routine is @@ -2401,29 +2322,6 @@ /*#define USE_STAT_BLOCKS / **/ #endif -/* HAS_STRUCT_STATFS_F_FLAGS: - * This symbol, if defined, indicates that the struct statfs - * does have the f_flags member containing the mount flags of - * the filesystem containing the file. - * This kind of struct statfs is coming from (BSD 4.3), - * not from (SYSV). Older BSDs (like Ultrix) do not - * have statfs() and struct statfs, they have ustat() and getmnt() - * with struct ustat and struct fs_data. - */ -/*#define HAS_STRUCT_STATFS_F_FLAGS / **/ - -/* HAS_STRUCT_STATFS: - * This symbol, if defined, indicates that the struct statfs - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_STATFS / **/ - -/* HAS_FSTATVFS: - * This symbol, if defined, indicates that the fstatvfs routine is - * available to stat filesystems by file descriptors. - */ -/*#define HAS_FSTATVFS / **/ - /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) * of the stdio FILE structure can be used to access the stdio buffer @@ -2636,12 +2534,6 @@ */ /*#define HAS_UNORDERED / **/ -/* HAS_USTAT: - * This symbol, if defined, indicates that the ustat system call is - * available to query file system statistics by dev_t. - */ -/*#define HAS_USTAT / **/ - /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ @@ -2823,12 +2715,6 @@ */ /*#define I_MACH_CTHREADS / **/ -/* I_MNTENT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_MNTENT / **/ - /* I_NETDB: * This symbol, if defined, indicates that exists and * should be included. @@ -2935,23 +2821,6 @@ */ /*#define I_SYSMODE / **/ -/* I_SYS_MOUNT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_MOUNT / **/ - -/* I_SYS_STATFS: - * This symbol, if defined, indicates that exists. - */ -/*#define I_SYS_STATFS / **/ - -/* I_SYS_STATVFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_STATVFS / **/ - /* I_SYSUIO: * This symbol, if defined, indicates that exists and * should be included. @@ -2964,12 +2833,6 @@ */ #define I_SYSUTSNAME /**/ -/* I_SYS_VFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_VFS / **/ - /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . @@ -2994,12 +2857,6 @@ /*#define I_SYS_TIME_KERNEL / **/ /*#define HAS_TM_TM_ZONE / **/ -/* I_USTAT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_USTAT / **/ - /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over * which perl.c:incpush() and lib/lib.pm will automatically diff --git a/plan9/config_sh.sample b/plan9/config_sh.sample index a236709..df9ec97 100644 --- a/plan9/config_sh.sample +++ b/plan9/config_sh.sample @@ -32,12 +32,12 @@ alignbytes='4' ansi2knr='' aphostname='/bin/uname -n' api_revision='5' -api_subversion='3' +api_subversion='4' api_version='23' -api_versionstring='5.23.3' +api_versionstring='5.23.4' ar='ar' -archlib='/sys/lib/perl5/5.23.3/386' -archlibexp='/sys/lib/perl5/5.23.3/386' +archlib='/sys/lib/perl5/5.23.4/386' +archlibexp='/sys/lib/perl5/5.23.4/386' archname64='' archname='386' archobjs='' @@ -222,11 +222,8 @@ d_fpclassl='undef' d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' -d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='define' -d_fstatfs='undef' -d_fstatvfs='undef' d_fsync='define' d_ftello='undef' d_ftime='undef' @@ -236,7 +233,6 @@ d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' d_getespwnam='undef' -d_getfsstat='undef' d_getgrent='define' d_getgrent_r='undef' d_getgrgid_r='undef' @@ -253,8 +249,6 @@ d_gethostprotos='undef' d_getitimer='undef' d_getlogin='define' d_getlogin_r='undef' -d_getmnt='undef' -d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' @@ -295,7 +289,6 @@ d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' -d_hasmntopt='undef' d_htonl='define' d_hypot='undef' d_ilogb='undef' @@ -521,10 +514,7 @@ d_sresgproto='undef' d_sresuproto='undef' d_stat='define' d_statblks='undef' -d_statfs_f_flags='undef' -d_statfs_s='undef' d_static_inline='undef' -d_statvfs='undef' d_stdio_cnt_lval='undef' d_stdio_ptr_lval='undef' d_stdio_ptr_lval_nochange_cnt='undef' @@ -583,7 +573,6 @@ d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' -d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' @@ -724,7 +713,6 @@ i_malloc='undef' i_mallocmalloc='undef' i_math='define' i_memory='undef' -i_mntent='undef' i_ndbm='undef' i_netdb='define' i_neterrno='undef' @@ -755,7 +743,6 @@ i_sysioctl='define' i_syslog='undef' i_sysmman='undef' i_sysmode='undef' -i_sysmount='undef' i_sysndir='undef' i_sysparam='define' i_syspoll='undef' @@ -764,8 +751,6 @@ i_syssecrt='undef' i_sysselct='define' i_syssockio='undef' i_sysstat='define' -i_sysstatfs='undef' -i_sysstatvfs='undef' i_systime='undef' i_systimek='undef' i_systimes='define' @@ -773,13 +758,11 @@ i_systypes='define' i_sysuio='define' i_sysun='define' i_sysutsname='define' -i_sysvfs='undef' i_syswait='define' i_termio='undef' i_termios='define' i_time='define' i_unistd='define' -i_ustat='undef' i_utime='define' i_values='undef' i_varargs='undef' @@ -790,17 +773,17 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='/sys/lib/perl/5.23.3/386' +installarchlib='/sys/lib/perl/5.23.4/386' installbin='/usr/bin' installman1dir='/sys/man/1pub' installman3dir='/sys/man/2pub' installprefix='/usr' installprefixexp='/usr' -installprivlib='/sys/lib/perl/5.23.3' +installprivlib='/sys/lib/perl/5.23.4' installscript='/usr/bin' -installsitearch='/sys/lib/perl/5.23.3/site_perl/386' +installsitearch='/sys/lib/perl/5.23.4/site_perl/386' installsitebin='/usr/bin' -installsitelib='/sys/lib/perl/5.23.3/site_perl' +installsitelib='/sys/lib/perl/5.23.4/site_perl' installstyle='lib/perl5' installusrbinperl='undef' installvendorarch='' @@ -925,8 +908,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/sys/lib/perl/5.23.3' -privlibexp='/sys/lib/perl/5.23.3' +privlib='/sys/lib/perl/5.23.4' +privlibexp='/sys/lib/perl/5.23.4' procselfexe='' prototype='define' ptrsize='4' @@ -991,13 +974,13 @@ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0' sig_size='50' signal_t='void' -sitearch='/sys/lib/perl/5.23.3/site_perl/386' +sitearch='/sys/lib/perl/5.23.4/site_perl/386' sitearchexp='/sys/lib/perl/site_perl/386' sitebin='/usr/bin' sitebinexp='/usr/bin' -sitelib='/sys/lib/perl/5.23.3/site_perl' -sitelib_stem='/sys/lib/perl/5.23.3/site_perl' -sitelibexp='/sys/lib/perl/5.23.3/site_perl' +sitelib='/sys/lib/perl/5.23.4/site_perl' +sitelib_stem='/sys/lib/perl/5.23.4/site_perl' +sitelibexp='/sys/lib/perl/5.23.4/site_perl' siteprefix='/usr' siteprefixexp='/usr' sizesize='4' @@ -1030,7 +1013,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/sys/include/ape/string.h' submit='' -subversion='3' +subversion='4' sysman='/sys/man/1pub' tail='' tar='' @@ -1112,8 +1095,8 @@ vendorlib_stem='' vendorlibexp='' vendorprefix='' vendorprefixexp='' -version='5.23.3' -version_patchlevel_string='version 23 subversion 3' +version='5.23.4' +version_patchlevel_string='version 23 subversion 4' versiononly='undef' vi='' xlibpth='' @@ -1127,9 +1110,9 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=23 -PERL_SUBVERSION=3 +PERL_SUBVERSION=4 PERL_API_REVISION=5 PERL_API_VERSION=23 -PERL_API_SUBVERSION=3 +PERL_API_SUBVERSION=4 PERL_PATCHLEVEL= PERL_CONFIG_SH=true diff --git a/pod/.gitignore b/pod/.gitignore index e6d5475..36b068b 100644 --- a/pod/.gitignore +++ b/pod/.gitignore @@ -53,7 +53,7 @@ /roffitall # generated -/perl5233delta.pod +/perl5234delta.pod /perlapi.pod /perlintern.pod *.html diff --git a/pod/perl.pod b/pod/perl.pod index d8d56eb..bd88731 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -180,6 +180,7 @@ aux c2ph h2ph h2xs perlbug pl2pm pod2html pod2man splain xsubpp perlhist Perl history records perldelta Perl changes since previous version + perl5233delta Perl changes in version 5.23.3 perl5232delta Perl changes in version 5.23.2 perl5231delta Perl changes in version 5.23.1 perl5230delta Perl changes in version 5.23.0 diff --git a/pod/perl5233delta.pod b/pod/perl5233delta.pod new file mode 100644 index 0000000..89f4a03 --- /dev/null +++ b/pod/perl5233delta.pod @@ -0,0 +1,404 @@ +=encoding utf8 + +=head1 NAME + +perl5233delta - what is new for perl v5.23.3 + +=head1 DESCRIPTION + +This document describes differences between the 5.23.2 release and the 5.23.3 +release. + +If you are upgrading from an earlier release such as 5.23.1, first read +L, which describes differences between 5.23.1 and 5.23.2. + +=head1 Core Enhancements + +=head2 C now works in UTF-8 locales + +L +now will successfully compile when S> is in effect. The compiled +pattern will use standard Unicode rules. If the runtime locale is not a +UTF-8 one, a warning is raised and standard Unicode rules are used +anyway. No tainting is done since the outcome does not actually depend +on the locale. + +=head1 Incompatible Changes + +=head2 An off by one issue in C<$Carp::MaxArgNums> has been fixed + +C<$Carp::MaxArgNums> is supposed to be the number of arguments to display. +Prior to this version, it was instead showing C<$Carp::MaxArgNums> + 1 arguments, +contrary to the documentation. + +=head1 Modules and Pragmata + +=head2 Updated Modules and Pragmata + +=over 4 + +=item * + +L has been upgraded from version 1.58 to 1.59. + +=item * + +L has been upgraded from version 0.39 to 0.40. + +=item * + +L has been upgraded from version 1.36 to 1.37. + +=item * + +L has been upgraded from version 2.068 to 2.068_01. + +=item * + +L has been upgraded from version 1.33 to 1.34. + +=item * + +L has been upgraded from version 2.76 to 2.77. + +=item * + +L has been upgraded from version 2.16 to 2.17. + +=item * + +L has been upgraded from version 1.09 to 1.10. + +=item * + +L has been upgraded from version 1.23 to 1.24. + +=item * + +L has been upgraded from version 0.013 to 0.014. + +=item * + +L has been upgraded from version 7.04_01 to 7.10. + +=item * + +L has been upgraded from version 3.29 to 3.30. + +=item * + +L has been upgraded from version 3.29 to 3.30. + +=item * + +L has been upgraded from version 1.30 to 1.31. + +=item * + +L has been upgraded from version 1.24 to 1.25. + +=item * + +L has been upgraded from version 3.57 to 3.58. + +=item * + +L has been upgraded from version 1.15 to 1.17. + +=item * + +L has been upgraded from version 0.0604 to 0.0605. + +=item * + +L has been upgraded from version 1.06 to 1.07. + +=item * + +L has been upgraded from version 3.35 to 3.36. + +=item * + +L has been upgraded from version 5.20150820 to 5.20150920. + +=item * + +L has been upgraded from version 1.17 to 1.18. + +=item * + +L has been upgraded from version 3.25 to 3.25_01. + +=item * + +L has been upgraded from version 1.56 to 1.57. + +=item * + +L has been upgraded from version 2.020 to 2.020_01. + +=item * + +L has been upgraded from version 1.26 to 1.27. + +=item * + +L has been upgraded from version 3.05 to 3.06. + +=item * + +L has been upgraded from version 2.02 to 2.03. + +=item * + +L has been upgraded from version 1.9726 to 1.9727_02. + +=item * + +L has been upgraded from version 0.62 to 0.63. + +=item * + +L has been upgraded from version 0.51 to 0.52. + +=back + +=head2 New Modules and Pragmata + +=over 4 + +=item * + +L has been added, as version 0.02 + +=item * + +L has been added, as version 0.01 + +=back + +=head1 Documentation + +=head2 Changes to Existing Documentation + +=head3 L + +=over 4 + +=item * + +A number of cleanups have been made to perlcall, including: + +=over 4 + +=item * + +use EXTEND(SP, n) and PUSHs() instead of XPUSHs() where applicable +and update prose to match + +=item * + +add POPu, POPul and POPpbytex to the "complete list of POP macros" +and clarify the documentation for some of the existing entries, and +a note about side-effects + +=item * + +add API documentation for POPu and POPul + +=item * + +use ERRSV more efficiently + +=item * + +approaches to thread-safety storage of SVs. + +=back + +=back + +=head3 L + +=over 4 + +=item * + +Discourage use of 'In' prefix for Unicode Block property. + +=back + +=head1 Diagnostics + +The following additions or changes have been made to diagnostic output, +including warnings and fatal error messages. For the complete list of +diagnostic messages, see L. + +=head2 New Diagnostics + +=head3 New Errors + +=over 4 + +=item * + +L<%s must not be a named sequence in transliteration operator|perldiag/"%s must not be a named sequence in transliteration operator"> + +(F) Transliteration (C and C) transliterates individual +characters. But a named sequence by definition is more than an +individual charater, and hence doing this operation on it doesn't make +sense. + +=back + +=head1 Testing + +=over 4 + +=item * + +Parallel building has been added to the dmake C makefile. All +Win32 compilers are supported. + +=back + +=head1 Platform Support + +=head2 Platform-Specific Notes + +=over 4 + +=item EBCDIC C and C fixed for UTF-EBCDIC strings + +Comparing two strings that were both encoded in UTF-8 (or more +precisely, UTF-EBCDIC) did not work properly until now. Since C +uses C, this fixes that as well. + +=item EBCDIC C and C fixed for C<\N{}>, and C> ranges + +Perl v5.22 introduced the concept of portable ranges to regular +expression patterns. A portable range matches the same set of +characters no matter what platform is being run on. This concept is now +extended to C. See +CEE|perlop/trESEARCHLISTEREPLACEMENTLISTEcdsr>>. + +There were also some problems with these operations under S>, which are now fixed + +=item Win32 + +=over + +=item * + +Parallel building has been added to the dmake C makefile. All +Win32 compilers are supported. + +=back + +=item AmigaOS + +The AmigaOS port has been reintegrated into the main tree, based off of +Perl 5.22.1. + +=item clang++ + +Don't add -shared when the compiler is clang++ + +=back + +=head1 Selected Bug Fixes + +=over 4 + +=item * + +C no longer segfaults, giving a syntax error message instead. +[perl #125805] + +=item * + +Regular expression possessive quantifier v5.20 regression now fixed. +CIC<{>I,IC<}+>C is supposed to behave identically +to C>IC<{>I,IC<})/>. Since v5.20, this didn't +work if I and I were equal. [perl #125825] + +=item * + +C<< BEGIN <> >> no longer segfaults and properly produces an error +message. [perl #125341] + +=item * + +In C an illegal backwards range like C was +not always detected, giving incorrect results. This is now fixed. + +=back + +=head1 Acknowledgements + +Perl 5.23.3 represents approximately 4 weeks of development since Perl 5.23.2 +and contains approximately 150,000 lines of changes across 550 files from 30 +authors. + +Excluding auto-generated files, documentation and release tools, there were +approximately 120,000 lines of changes to 410 .pm, .t, .c and .h files. + +Perl continues to flourish into its third decade thanks to a vibrant community +of users and developers. The following people are known to have contributed the +improvements that became Perl 5.23.3: + +Aaron Crane, Alexander D'Archangel, Andy Broad, Chris 'BinGOs' Williams, Craig +A. Berry, Dan Collins, Daniel Dragan, David Mitchell, Father Chrysostomos, +James E Keenan, Jan Dubois, Jarkko Hietaniemi, Jerry D. Hedden, John SJ +Anderson, Karen Etheridge, Karl Williamson, Lukas Mai, Matthew Horsfall, +Nicolas R., Peter John Acklam, Peter Martini, Ricardo Signes, Shlomi Fish, +Steffen Müller, Steve Hay, Sullivan Beck, Thomas Sibley, Todd Rinaldo, Tony +Cook, Zachary Storer. + +The list above is almost certainly incomplete as it is automatically generated +from version control history. In particular, it does not include the names of +the (very much appreciated) contributors who reported issues to the Perl bug +tracker. + +Many of the changes included in this version originated in the CPAN modules +included in Perl's core. We're grateful to the entire CPAN community for +helping Perl to flourish. + +For a more complete list of all of Perl's historical contributors, please see +the F file in the Perl source distribution. + +=head1 Reporting Bugs + +If you find what you think is a bug, you might check the articles recently +posted to the comp.lang.perl.misc newsgroup and the perl bug database at +L . There may also be information at +L , the Perl Home Page. + +If you believe you have an unreported bug, please run the L program +included with your release. Be sure to trim your bug down to a tiny but +sufficient test case. Your bug report, along with the output of C, +will be sent off to perlbug@perl.org to be analysed by the Perl porting team. + +If the bug you are reporting has security implications, which make it +inappropriate to send to a publicly archived mailing list, then please send it +to perl5-security-report@perl.org. This points to a closed subscription +unarchived mailing list, which includes all the core committers, who will be +able to help assess the impact of issues, figure out a resolution, and help +co-ordinate the release of patches to mitigate or fix the problem across all +platforms on which Perl is supported. Please only use this address for +security issues in the Perl core, not for modules independently distributed on +CPAN. + +=head1 SEE ALSO + +The F file for an explanation of how to view exhaustive details on +what changed. + +The F file for how to build Perl. + +The F file for general stuff. + +The F and F files for copyright information. + +=cut diff --git a/pod/perldebguts.pod b/pod/perldebguts.pod index 6bd38c1..5024d98 100644 --- a/pod/perldebguts.pod +++ b/pod/perldebguts.pod @@ -755,8 +755,9 @@ will be lost. # Backtracking Verbs ENDLIKE none Used only for the type field of verbs - OPFAIL none Same as (?!) - ACCEPT parno 1 Accepts the current matched string. + OPFAIL no-sv 1 Same as (?!), but with verb arg + ACCEPT no-sv/num Accepts the current matched string, with + 2L verbar # Verbs With Arguments VERB no-sv 1 Used only for the type field of verbs diff --git a/pod/perldelta.pod b/pod/perldelta.pod index ab02a04..8d0d633 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -2,288 +2,343 @@ =head1 NAME -perldelta - what is new for perl v5.23.3 +perldelta - what is new for perl v5.23.4 =head1 DESCRIPTION -This document describes differences between the 5.23.2 release and the 5.23.3 +This document describes differences between the 5.23.3 release and the 5.23.4 release. -If you are upgrading from an earlier release such as 5.23.1, first read -L, which describes differences between 5.23.1 and 5.23.2. - -=head1 Core Enhancements - -=head2 C now works in UTF-8 locales - -L -now will successfully compile when S> is in effect. The compiled -pattern will use standard Unicode rules. If the runtime locale is not a -UTF-8 one, a warning is raised and standard Unicode rules are used -anyway. No tainting is done since the outcome does not actually depend -on the locale. +If you are upgrading from an earlier release such as 5.23.2, first read +L, which describes differences between 5.23.2 and 5.23.3. =head1 Incompatible Changes -=head2 An off by one issue in C<$Carp::MaxArgNums> has been fixed +=head2 Lexical $_ has been removed -C<$Carp::MaxArgNums> is supposed to be the number of arguments to display. -Prior to this version, it was instead showing C<$Carp::MaxArgNums> + 1 arguments, -contrary to the documentation. +C was introduced in Perl 5.10, and subsequently caused much confusion +with no obvious solution. In Perl 5.18.0, it was made experimental on the +theory that it would either be removed or redesigned in a less confusing (but +backward-incompatible) way. Over the following years, no alternatives were +proposed. The feature has now been removed and will fail to compile. -=head1 Modules and Pragmata +=head2 Only blanks and tabs are now allowed within C<[...]> within C<(?[...])>. -=head2 Updated Modules and Pragmata +The experimental Extended Bracketed Character Classes can contain regular +bracketed character classes within them. These differ from regular ones in +that white space is generally ignored, unless escaped by preceding it with a +backslash. The white space that is ignored is now limited to just tab C<\t> +and SPACE characters. Previously, it was any white space. See +L. + +=head1 Performance Enhancements =over 4 =item * -L has been upgraded from version 1.58 to 1.59. +C has been made much faster. -=item * +On platforms with a libc memchr() implementation which makes good use of +underlying hardware support, patterns which include fixed substrings will now +often be much faster; for example with glibc on a recent x86_64 CPU, this: -L has been upgraded from version 0.39 to 0.40. + $s = "a" x 1000 . "wxyz"; + $s =~ /wxyz/ for 1..30000 -=item * +is now about 7 times faster. On systems with slow memchr(), e.g. 32-bit ARM +Raspberry Pi, there will be a small or little speedup. Conversely, some +pathological cases, such as C<"ab" x 1000 =~ /aa/> will be slower now; up to 3 +times slower on the rPi, 1.5x slower on x86_64. -L has been upgraded from version 1.36 to 1.37. +=back -=item * +=head1 Modules and Pragmata -L has been upgraded from version 2.068 to 2.068_01. +=head2 Updated Modules and Pragmata + +=over 4 =item * -L has been upgraded from version 1.33 to 1.34. +L has been upgraded from version 1.59 to 1.60. =item * -L has been upgraded from version 2.76 to 2.77. +L has been upgraded from version 0.40 to 0.41. =item * -L has been upgraded from version 2.16 to 2.17. +L has been upgraded from version 2.068 to 2.069. =item * -L has been upgraded from version 1.09 to 1.10. +L has been upgraded from version 2.068_01 to 2.069. =item * -L has been upgraded from version 1.23 to 1.24. +L has been upgraded from version 3.31 to 3.32. =item * -L has been upgraded from version 0.013 to 0.014. +L has been upgraded from version 1.34 to 1.35. =item * -L has been upgraded from version 7.04_01 to 7.10. +L has been upgraded from version 2.77 to 2.78. =item * -L has been upgraded from version 3.29 to 3.30. +L has been upgraded from version 0.014 to 0.016. =item * -L has been upgraded from version 3.29 to 3.30. +L has been upgraded from version 0.280223 to 0.280224. =item * -L has been upgraded from version 1.30 to 1.31. +L has been upgraded from version 2.11 to 2.12. =item * -L has been upgraded from version 1.24 to 1.25. +L has been upgraded from version 0.0605 to 0.0606. =item * -L has been upgraded from version 3.57 to 3.58. +L has been upgraded from version 1.35 to 1.36. + +For an IO::Poll object C<$poll> with no file handles yet in it, +C<$poll-Epoll(10)> now sleeps for up to 10 seconds anyway instead of +returning 0 immediately. +L<[cpan #25049]|https://rt.cpan.org/Ticket/Display.html?id=25049> =item * -L has been upgraded from version 1.15 to 1.17. +The IO-Compress modules have been upgraded from version 2.068 to 2.069. =item * -L has been upgraded from version 0.0604 to 0.0605. +L has been upgraded from version 1.999701 to 1.999704. =item * -L has been upgraded from version 1.06 to 1.07. +L has been upgraded from version 0.31 to 0.34. =item * -L has been upgraded from version 3.35 to 3.36. +L has been upgraded from version 5.20150920 to 5.20151020. =item * -L has been upgraded from version 5.20150820 to 5.20150920. +L has been upgraded from version 1.000027 to 1.000029. =item * -L has been upgraded from version 1.17 to 1.18. +L has been upgraded from version 1.008 to 1.009. =item * -L has been upgraded from version 3.25 to 3.25_01. +L has been upgraded from version 0.21 to 0.22. + +PerlIO::encoding objects are now properly duplicated. +L<[perl #31923]|https://rt.perl.org/Ticket/Display.html?id=31923> =item * -L has been upgraded from version 1.56 to 1.57. +L has been upgraded from version 1.57 to 1.58. + +If C was passed C<$!> as its argument then it accidentally +cleared C<$!>. This has been fixed. +L<[perl #126229]|https://rt.perl.org/Ticket/Display.html?id=126229> =item * -L has been upgraded from version 2.020 to 2.020_01. +L has been upgraded from version 2.020_01 to 2.020_02. + +Various fixes have been applied to inet_pton for the benefit of MS VC++ builds +on Windows. In particular, this restores the build with MS VC++ 6.0. =item * -L has been upgraded from version 1.26 to 1.27. +L has been upgraded from version 1.19 to 1.21. =item * -L has been upgraded from version 3.05 to 3.06. +L has been upgraded from version 1.33 to 1.35. -=item * +The C example now actually uses C. +L<[perl #126051]|https://rt.perl.org/Ticket/Display.html?id=126051> -L has been upgraded from version 2.02 to 2.03. +=back -=item * +=head1 Documentation -L has been upgraded from version 1.9726 to 1.9727_02. +=head2 Changes to Existing Documentation -=item * +=head3 L -L has been upgraded from version 0.62 to 0.63. +=over 4 =item * -L has been upgraded from version 0.51 to 0.52. +The process of using undocumented globals has been documented, namely, that one +should send email to L +first to get the go-ahead for documenting and using an undocumented function or +global variable. =back -=head2 New Modules and Pragmata +=head3 L =over 4 =item * -L has been added, as version 0.02 +Updated to note that anonymous subroutines can have signatures. -=item * +=back -L has been added, as version 0.01 +=head3 L -=back +=over 4 -=head1 Documentation +=item * -=head2 Changes to Existing Documentation +The usage of C and C has been clarified. -=head3 L +=back + +=head3 L =over 4 =item * -A number of cleanups have been made to perlcall, including: +The specific true value of C<$!{E...}> is now documented, noting that it is +subject to change and not guaranteed. + +=back + +=head1 Diagnostics + +The following additions or changes have been made to diagnostic output, +including warnings and fatal error messages. For the complete list of +diagnostic messages, see L. + +=head2 New Diagnostics + +=head3 New Errors =over 4 =item * -use EXTEND(SP, n) and PUSHs() instead of XPUSHs() where applicable -and update prose to match +L =item * -add POPu, POPul and POPpbytex to the "complete list of POP macros" -and clarify the documentation for some of the existing entries, and -a note about side-effects +L =item * -add API documentation for POPu and POPul +L -=item * +=back + +=head2 Changes to Existing Diagnostics -use ERRSV more efficiently +=over 4 =item * -approaches to thread-safety storage of SVs. +L -=back +This error now reports the name of the non-lvalue subroutine you attempted to +use as an lvalue. =back -=head3 L +=head1 Configuration and Compilation =over 4 =item * -Discourage use of 'In' prefix for Unicode Block property. +Using the C define in combination with the default hash algorithm +C resulted in a fatal error while compiling +the interpreter, since Perl 5.17.10. This has been fixed. -=back +=item * -=head1 Diagnostics +If you had F hints for C or C, they were +probably broken by the AmigaOS changes in Perl 5.23.3. This has been now +fixed. +L<[perl #126152]|https://rt.perl.org/Ticket/Display.html?id=126152> -The following additions or changes have been made to diagnostic output, -including warnings and fatal error messages. For the complete list of -diagnostic messages, see L. +=back -=head2 New Diagnostics +=head1 Platform Support -=head3 New Errors +=head2 Platform-Specific Notes =over 4 +=item IRIX + +=over + =item * -L<%s must not be a named sequence in transliteration operator|perldiag/"%s must not be a named sequence in transliteration operator"> +Under some circumstances IRIX stdio fgetc() and fread() set the errno to +C, which made no sense according to either IRIX or POSIX docs. Errno +is now cleared in such cases. +L<[perl #123977]|https://rt.perl.org/Ticket/Display.html?id=123977> + +=item * -(F) Transliteration (C and C) transliterates individual -characters. But a named sequence by definition is more than an -individual charater, and hence doing this operation on it doesn't make -sense. +Problems when multiplying long doubles by infinity have been fixed. +L<[perl #126396]|https://rt.perl.org/Ticket/Display.html?id=126396> =back -=head1 Testing +=item MacOS X -=over 4 +=over =item * -Parallel building has been added to the dmake C makefile. All -Win32 compilers are supported. +Until now OS X builds of perl have specified a link target of 10.3 (Panther, +2003) but have not specified a compiler target. From now on, builds of perl on +OS X 10.6 or later (Snow Leopard, 2008) by default capture the current OS X +version and specify that as the explicit build target in both compiler and +linker flags, thus preserving binary compatibility for extensions built later +regardless of changes in OS X, SDK, or compiler and linker versions. To +override the default value used in the build and preserved in the flags, +specify C before configuring and building +perl, where 10.N is the version of OS X you wish to target. In OS X 10.5 or +earlier there is no change to the behavior present when those systems were +current; the link target is still OS X 10.3 and there is no explicit compiler +target. =back -=head1 Platform Support - -=head2 Platform-Specific Notes +=item VMS -=over 4 +=over -=item EBCDIC C and C fixed for UTF-EBCDIC strings +=item * -Comparing two strings that were both encoded in UTF-8 (or more -precisely, UTF-EBCDIC) did not work properly until now. Since C -uses C, this fixes that as well. +Perl now implements its own C by scanning for processes in the +specified process group, which may not mean exactly the same thing as a Unix +process group, but allows us to send a signal to a parent (or master) process +and all of its sub-processes. At the perl level, this means we can now send a +negative pid like so: -=item EBCDIC C and C fixed for C<\N{}>, and C> ranges + kill SIGKILL, -$pid; -Perl v5.22 introduced the concept of portable ranges to regular -expression patterns. A portable range matches the same set of -characters no matter what platform is being run on. This concept is now -extended to C. See -CEE|perlop/trESEARCHLISTEREPLACEMENTLISTEcdsr>>. +to signal all processes in the same group as C<$pid>. -There were also some problems with these operations under S>, which are now fixed +=back =item Win32 @@ -291,19 +346,65 @@ utf8>>, which are now fixed =item * -Parallel building has been added to the dmake C makefile. All -Win32 compilers are supported. +A new build option C has been added to the makefiles. This +option is off by default, meaning the default is to do Windows registry +lookups. This option stops Perl from looking inside the registry for anything. +For what values are looked up in the registry see L. Internally, in +C, the name of this option is C. + +=item * + +The behavior of Perl using C and +C to lookup certain values, including C<%ENV> +vars starting with C has changed. Previously, the 2 keys were checked +for entries at all times through Perl processes life time even if they did not +exist. For performance reasons, now, if the root key (i.e. +C or C) does +not exist at process start time, it will not be checked again for C<%ENV> +override entries for the remainder of the Perl processes life. This more +closely matches Unix behaviour in that the environment is copied or inherited +on startup and changing the variable in the parent process or another process +or editing F<.bashrc> will not change the environmental variable in other +existing, running, processes. + +=item * + +One glob fetch was removed for each C<-X> or C call whether done from +Perl code or internally from Perl's C code. The glob being looked up was +C<${^WIN32_SLOPPY_STAT}> which is a special variable. This makes C<-X> and +C slightly faster. + +=item * + +During miniperl's process startup, during the build process, 4 to 8 IO calls +related to the process starting F<.pl> and the F file were +removed from the code opening and executing the first 1 or 2 F<.pl> files. =back -=item AmigaOS +=back + +=head1 Internal Changes -The AmigaOS port has been reintegrated into the main tree, based off of -Perl 5.22.1. +=over 4 -=item clang++ +=item * + +L had its return type changed from C to C. It +previously has always returned C<0> since Perl 5.000 stable but that was +undocumented. Although C is marked as public API, XS code is not +expected to be impacted since the proper API call would be through public API +C, or quasi-public C, or non-public +C calls, and the return value of C was previously a +meaningless constant that can be rewritten as C<(sv_backoff(sv),0)>. + +=item * -Don't add -shared when the compiler is clang++ +The C and C macros have been improved to avoid various issues +with integer truncation and wrapping. In particular, some casts formerly used +within the macros have been removed. This means for example that passing an +unsigned nitems argument is likely to raise a compiler warning now (it's always +been documented to require a signed value; formerly int, lately SSize_t). =back @@ -313,56 +414,108 @@ Don't add -shared when the compiler is clang++ =item * -C no longer segfaults, giving a syntax error message instead. -[perl #125805] +There were places in regular expression patterns where comments (C<(?#...)>) +weren't allowed, but should have been. This is now fixed. +L<[perl #116639]|https://rt.perl.org/Ticket/Display.html?id=116639> + +=item * + +Some regressions from Perl 5.20 have been fixed, in which some syntax errors in +L|perlrecharclass/Extended Bracketed Character Classes> constructs +within regular expression patterns could cause a segfault instead of a proper +error message. +L<[perl #126180]|https://rt.perl.org/Ticket/Display.html?id=126180> +L<[perl #126404]|https://rt.perl.org/Ticket/Display.html?id=126404> + +=item * + +Another problem with +L|perlrecharclass/Extended Bracketed Character Classes> +constructs has been fixed wherein things like C<\c]> could cause panics. +L<[perl #126181]|https://rt.perl.org/Ticket/Display.html?id=126181> + +=item * + +Some problems with attempting to extend the perl stack to around 2G or 4G +entries have been fixed. This was particularly an issue on 32-bit perls built +to use 64-bit integers, and was easily noticeable with the list repetition +operator, e.g. + + @a = (1) x $big_number + +Formerly perl may have crashed, depending on the exact value of C<$big_number>; +now it will typically raise an exception. +L<[perl #125937]|https://rt.perl.org/Ticket/Display.html?id=125937> + +=item * + +In a regex conditional expression C<(?(condition)yes-pattern|no-pattern)>, if +the condition is C<(?!)> then perl failed the match outright instead of +matching the no-pattern. This has been fixed. +L<[perl #126222]|https://rt.perl.org/Ticket/Display.html?id=126222> =item * -Regular expression possessive quantifier v5.20 regression now fixed. -CIC<{>I,IC<}+>C is supposed to behave identically -to C>IC<{>I,IC<})/>. Since v5.20, this didn't -work if I and I were equal. [perl #125825] +The special backtracking control verbs C<(*VERB:ARG)> now all allow an optional +argument and set C/C appropriately as well. +L<[perl #126186]|https://rt.perl.org/Ticket/Display.html?id=126186> =item * -C<< BEGIN <> >> no longer segfaults and properly produces an error -message. [perl #125341] +Several bugs, including a segmentation fault, have been fixed with the bounds +checking constructs (introduced in Perl 5.22) C<\b{gcb}>, C<\b{sb}>, C<\b{wb}>, +C<\B{gcb}>, C<\B{sb}>, and C<\B{wb}>. All the C<\B{}> ones now match an empty +string; none of the C<\b{}> ones do. +L<[perl #126319]|https://rt.perl.org/Ticket/Display.html?id=126319> + +=back + +=head1 Errata From Previous Releases + +=over 4 =item * -In C an illegal backwards range like C was -not always detected, giving incorrect results. This is now fixed. +(This was actually done in Perl 5.23.2, but the perldelta entry got missed.) +The way that C handles assignment with potentially common values +(e.g. C<($a,$b) = ($b, $a)> has changed. In particular the C +flag has been replaced with three more specific flags: + + OPpASSIGN_COMMON_AGG + OPpASSIGN_COMMON_RC1 + OPpASSIGN_COMMON_SCALAR + +and the runtime now sometimes does a mark and sweep using the C to +detect common elements. =back =head1 Acknowledgements -Perl 5.23.3 represents approximately 4 weeks of development since Perl 5.23.2 -and contains approximately 150,000 lines of changes across 550 files from 30 +Perl 5.23.4 represents approximately 4 weeks of development since Perl 5.23.3 +and contains approximately 21,000 lines of changes across 360 files from 21 authors. Excluding auto-generated files, documentation and release tools, there were -approximately 120,000 lines of changes to 410 .pm, .t, .c and .h files. +approximately 15,000 lines of changes to 250 .pm, .t, .c and .h files. Perl continues to flourish into its third decade thanks to a vibrant community -of users and developers. The following people are known to have contributed the -improvements that became Perl 5.23.3: +of users and developers. The following people are known to have contributed +the improvements that became Perl 5.23.4: -Aaron Crane, Alexander D'Archangel, Andy Broad, Chris 'BinGOs' Williams, Craig -A. Berry, Dan Collins, Daniel Dragan, David Mitchell, Father Chrysostomos, -James E Keenan, Jan Dubois, Jarkko Hietaniemi, Jerry D. Hedden, John SJ -Anderson, Karen Etheridge, Karl Williamson, Lukas Mai, Matthew Horsfall, -Nicolas R., Peter John Acklam, Peter Martini, Ricardo Signes, Shlomi Fish, -Steffen Müller, Steve Hay, Sullivan Beck, Thomas Sibley, Todd Rinaldo, Tony -Cook, Zachary Storer. +Chris 'BinGOs' Williams, Craig A. Berry, Dagfinn Ilmari Mannsåker, Daniel +Dragan, David Mitchell, Doug Bell, Father Chrysostomos, H.Merijn Brand, Jarkko +Hietaniemi, Karen Etheridge, Karl Williamson, Nicholas Clark, Peter Martini, +Rafael Garcia-Suarez, Reini Urban, Ricardo Signes, Steve Hay, Tony Cook, Victor +Adam, Vincent Pit, Yves Orton. The list above is almost certainly incomplete as it is automatically generated -from version control history. In particular, it does not include the names of +from version control history. In particular, it does not include the names of the (very much appreciated) contributors who reported issues to the Perl bug tracker. Many of the changes included in this version originated in the CPAN modules -included in Perl's core. We're grateful to the entire CPAN community for +included in Perl's core. We're grateful to the entire CPAN community for helping Perl to flourish. For a more complete list of all of Perl's historical contributors, please see diff --git a/pod/perldiag.pod b/pod/perldiag.pod index b89ba40..db798d7 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -868,13 +868,6 @@ found in the PATH did not have correct permissions. (F) A string of a form C was given to prototype(), but there is no builtin with the name C. -=item Can't find %s character property "%s" - -(F) You used C<\p{}> or C<\P{}> but the character property by that name -could not be found. Maybe you misspelled the name of the property? -See L -for a complete list of available official properties. - =item Can't find label %s (F) You said to goto a label that isn't mentioned anywhere that it's @@ -907,13 +900,19 @@ L for the full details on here-documents. =item Can't find Unicode property definition "%s" -(F) You may have tried to use C<\p> which means a Unicode -property (for example C<\p{Lu}> matches all uppercase -letters). If you did mean to use a Unicode property, see +=item Can't find Unicode property definition "%s" in regex; marked by <-- HERE in m/%s/ + +(F) The named property which you specified via C<\p> or C<\P> is not one +known to Perl. Perhaps you misspelled the name? See L -for a complete list of available properties. If you didn't -mean to use a Unicode property, escape the C<\p>, either by -C<\\p> (just the C<\p>) or by C<\Q\p> (the rest of the string, or +for a complete list of available official +properties. If it is a +L +it must have been defined by the time the regular expression is +matched. + +If you didn't mean to use a Unicode property, escape the C<\p>, either +by C<\\p> (just the C<\p>) or by C<\Q\p> (the rest of the string, or until C<\E>). =item Can't fork: %s @@ -1108,7 +1107,7 @@ to change it, such as with an auto-increment. (P) The internal routine that does assignment to a substr() was handed a NULL. -=item Can't modify non-lvalue subroutine call +=item Can't modify non-lvalue subroutine call of &%s (F) Subroutines meant to be used in lvalue context should be declared as such. See L. @@ -1478,6 +1477,13 @@ Note that ASCII characters that don't map to control characters are discouraged, and will generate the warning (when enabled) L. +=item Character following \%c must be '{' or a single-character Unicode property name in regex; marked by <-- HERE in m/%s/ + +(F) (In the above the C<%c> is replaced by either C

or C

.) You +specified something that isn't a legal Unicode property name. Most +Unicode properties are specified by C<\p{...}>. But if the name is a +single character one, the braces may be omitted. + =item Character in 'C' format wrapped in pack (W pack) You said @@ -2543,6 +2549,15 @@ L)>|perlre/(?PARNO) (?-PARNO) (?+PARNO) (?R) (?0)>. (X) The PERL5OPT environment variable may only be used to set the following switches: B<-[CDIMUdmtw]>. +=item Illegal user-defined property name + +(F) You specified a Unicode-like property name in a regular expression +pattern (using C<\p{}> or C<\P{}>) that Perl knows isn't an official +Unicode property, and was likely meant to be a user-defined property +name, but it can't be one of those, as they must begin with either C +or C. Check the spelling. See also +L. + =item Ill-formed CRTL environ value "%s" (W internal) A warning peculiar to VMS. Perl tried to read the CRTL's @@ -4813,16 +4828,6 @@ port. One can easily disable this by appropriate sighandlers, see L. See also "Process terminated by SIGTERM/SIGINT" in L. -=item Property '%s' is unknown in regex; marked by S<<-- HERE> in m/%s/ - -(F) The named property which you specified via C<\p> or C<\P> is not one -known to Perl. Perhaps you misspelled the name? See -L -for a complete list of available official -properties. If it is a L -it must have been defined by the time the regular expression is -compiled. - =item Prototype after '%c' for %s : %s (W illegalproto) A character follows % or @ in a prototype. This is @@ -6742,12 +6747,6 @@ for historical reasons. it already went past any symlink you are presumably trying to look for. The operation returned C. Use a filename instead. -=item Use of my $_ is experimental - -(S experimental::lexical_topic) Lexical $_ is an experimental feature and -its behavior may change or even be removed in any future release of perl. -See the explanation under L. - =item Use of %s on a handle without * is deprecated (D deprecated) You used C, C or C on a scalar but that scalar diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 1759ad1..f0a2abb 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -2893,7 +2893,7 @@ C matches all files in the current working directory. If you want to glob filenames that might contain whitespace, you'll have to use extra quotes around the spacey filename to protect it. For example, to glob filenames that have an C followed by a space -followed by an C, use either of: +followed by an C, use one of: @spacies = <"*e f*">; @spacies = glob '"*e f*"'; @@ -3021,12 +3021,6 @@ element of a list returned by grep (for example, in a C, C or another C) actually modifies the element in the original list. This is usually something to be avoided when writing clear code. -If C<$_> is lexical in the scope where the C appears (because it has -been declared with the deprecated C construct) -then, in addition to being locally aliased to -the list elements, C<$_> keeps being lexical inside the block; i.e., it -can't be seen from the outside, avoiding any potential side-effects. - See also L for a list composed of the results of the BLOCK or EXPR. =item hex EXPR @@ -3659,12 +3653,6 @@ Using a regular C loop for this purpose would be clearer in most cases. See also L for an array composed of those items of the original list for which the BLOCK or EXPR evaluates to true. -If C<$_> is lexical in the scope where the C appears (because it has -been declared with the deprecated C construct), -then, in addition to being locally aliased to -the list elements, C<$_> keeps being lexical inside the block; that is, it -can't be seen from the outside, avoiding any potential side-effects. - C<{> starts both hash references and blocks, so C could be either the start of map BLOCK LIST or map EXPR, LIST. Because Perl doesn't look ahead for the closing C<}> it has to take a guess at which it's dealing with diff --git a/pod/perlgit.pod b/pod/perlgit.pod index 3eb0dbb..f5d4fec 100644 --- a/pod/perlgit.pod +++ b/pod/perlgit.pod @@ -616,6 +616,11 @@ C: % git am 0001-Rename-Leon-Brocard-to-Orange-Brocard.patch Applying Rename Leon Brocard to Orange Brocard +Note that some UNIX mail systems can mess with text attachments containing +'From '. This will fix them up: + + % perl -pi -e's/^>From /From /' 0001-Rename-Leon-Brocard-to-Orange-Brocard.patch + If just a raw diff is provided, it is also possible use this two-step process: diff --git a/pod/perlhacktips.pod b/pod/perlhacktips.pod index 5a3fb25..4546399 100644 --- a/pod/perlhacktips.pod +++ b/pod/perlhacktips.pod @@ -601,6 +601,10 @@ temporarily try the following: But in any case, try to keep the features and operating systems separate. +A good resource on the predefined macros for various operating +systems, compilers, and so forth is +L + =item * Assuming the contents of static memory pointed to by the return values @@ -1040,6 +1044,17 @@ a testbed for their product they periodically check several open source projects, and they give out accounts to open source developers to the defect databases. +There is Coverity setup for the perl5 project: +L + +=head2 HP-UX cadvise (Code Advisor) + +HP has a C/C++ static analyzer product for HP-UX caller Code Advisor. +(Link not given here because the URL is horribly long and seems horribly +unstable; use the search engine of your choice to find it.) The use of +the C recipe with C +(see cadvise "User Guide") is recommended; as is the use of C<+wall>. + =head2 cpd (cut-and-paste detector) The cpd tool detects cut-and-paste coding. If one instance of the diff --git a/pod/perlhist.pod b/pod/perlhist.pod index b9e369f..5d3eb92 100644 --- a/pod/perlhist.pod +++ b/pod/perlhist.pod @@ -565,6 +565,7 @@ the strings?). Matthew 5.23.1 2015-Jul-20 Matthew 5.23.2 2015-Aug-20 Peter 5.23.3 2015-Sep-20 + Steve 5.23.4 2015-Oct-20 =head2 SELECTED RELEASE SIZES diff --git a/pod/perlport.pod b/pod/perlport.pod index 02536d9..8e872e4 100644 --- a/pod/perlport.pod +++ b/pod/perlport.pod @@ -1754,8 +1754,8 @@ the Unix semantics, where the signal will be delivered to all processes in the same process group as the process specified by $pid. (Win32) -Is not supported for process identification number of 0 or negative -numbers. (VMS) +A pid of -1 indicating all processes on the system is not currently +supported. (VMS) =item link diff --git a/pod/perlre.pod b/pod/perlre.pod index a262b4c..2a4516c 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -22,6 +22,8 @@ find things that, while legal, may not be what you intended. =head2 Modifiers +=head3 Overview + Matching operations can have various modifiers. Modifiers that relate to the interpretation of the regular expression inside are listed below. Modifiers that alter the way a regular expression @@ -152,11 +154,16 @@ L are: Regular expression modifiers are usually written in documentation as e.g., "the C modifier", even though the delimiter -in question might not really be a slash. The modifiers C +in question might not really be a slash. The modifiers C may also be embedded within the regular expression itself using the C<(?...)> construct, see L below. -=head3 /x +=head3 Details on some modifiers + +Some of the modifiers require more explanation than given in the +L above. + +=head4 /x C tells the regular expression parser to ignore most whitespace that is neither @@ -220,7 +227,7 @@ calls "Pattern White Space", namely: U+2028 LINE SEPARATOR U+2029 PARAGRAPH SEPARATOR -=head3 Character set modifiers +=head4 Character set modifiers C, C, C, and C, available starting in 5.14, are called the character set modifiers; they affect the character set rules @@ -1067,9 +1074,9 @@ a backslash if it appears in the comment. See Lx> for another way to have comments in patterns. -=item C<(?adlupimsx-imsx)> +=item C<(?adlupimnsx-imnsx)> -=item C<(?^alupimsx)> +=item C<(?^alupimnsx)> X<(?)> X<(?^)> One or more embedded pattern-match modifiers, to be turned on (or @@ -1107,7 +1114,7 @@ expressions compiled within the scope of a C. See L. Starting in Perl 5.14, a C<"^"> (caret or circumflex accent) immediately -after the C<"?"> is a shorthand equivalent to C. Flags (except +after the C<"?"> is a shorthand equivalent to C. Flags (except C<"d">) may follow the caret to override it. But a minus sign is not legal with it. @@ -1125,9 +1132,9 @@ anywhere in a pattern has a global effect. =item C<(?:pattern)> X<(?:)> -=item C<(?adluimsx-imsx:pattern)> +=item C<(?adluimnsx-imnsx:pattern)> -=item C<(?^aluimsx:pattern)> +=item C<(?^aluimnsx:pattern)> X<(?^:)> This is for clustering, not capturing; it groups subexpressions like @@ -1143,7 +1150,7 @@ but doesn't spit out extra fields. It's also cheaper not to capture characters if you don't need to. Any letters between C and C<:> act as flags modifiers as with -C<(?adluimsx-imsx)>. For example, +C<(?adluimnsx-imnsx)>. For example, /(?s-i:more.*than).*million/i @@ -1151,18 +1158,21 @@ is equivalent to the more verbose /(?:(?s-i)more.*than).*million/i +Note that any C<(...)> constructs enclosed within this one will still +capture unless the C modifier is in effect. + Starting in Perl 5.14, a C<"^"> (caret or circumflex accent) immediately -after the C<"?"> is a shorthand equivalent to C. Any positive +after the C<"?"> is a shorthand equivalent to C. Any positive flags (except C<"d">) may follow the caret, so (?^x:foo) is equivalent to - (?x-ims:foo) + (?x-imns:foo) The caret tells Perl that this cluster doesn't inherit the flags of any -surrounding pattern, but uses the system defaults (C), +surrounding pattern, but uses the system defaults (C), modified by any flags specified. The caret allows for simpler stringification of compiled regular @@ -1856,7 +1866,7 @@ See L. These special patterns are generally of the form C<(*VERB:ARG)>. Unless otherwise stated the ARG argument is optional; in some cases, it is -forbidden. +mandatory. Any pattern containing a special backtracking verb that allows an argument has the special behaviour that when executed it sets the current package's @@ -1884,7 +1894,7 @@ argument, then C<$REGERROR> and C<$REGMARK> are not touched at all. =over 3 -=item Verbs that take an argument +=item Verbs =over 4 @@ -2040,13 +2050,7 @@ is not the same as as after matching the A but failing on the B the C<(*THEN)> verb will backtrack and try C; but the C<(*PRUNE)> verb will simply fail. -=back - -=item Verbs without an argument - -=over 4 - -=item C<(*COMMIT)> +=item C<(*COMMIT)> C<(*COMMIT:args)> X<(*COMMIT)> This is the Perl 6 "commit pattern" C<< >> or C<:::>. It's a @@ -2067,16 +2071,18 @@ In other words, once the C<(*COMMIT)> has been entered, and if the pattern does not match, the regex engine will not try any further matching on the rest of the string. -=item C<(*FAIL)> C<(*F)> +=item C<(*FAIL)> C<(*F)> C<(*FAIL:arg)> X<(*FAIL)> X<(*F)> This pattern matches nothing and always fails. It can be used to force the engine to backtrack. It is equivalent to C<(?!)>, but easier to read. In -fact, C<(?!)> gets optimised into C<(*FAIL)> internally. +fact, C<(?!)> gets optimised into C<(*FAIL)> internally. You can provide +an argument so that if the match fails because of this FAIL directive +the argument can be obtained from $REGERROR. It is probably useful only when combined with C<(?{})> or C<(??{})>. -=item C<(*ACCEPT)> +=item C<(*ACCEPT)> C<(*ACCEPT:arg)> X<(*ACCEPT)> This pattern matches nothing and causes the end of successful matching at @@ -2095,6 +2101,9 @@ will match, and C<$1> will be C and C<$2> will be C, C<$3> will not be set. If another branch in the inner parentheses was matched, such as in the string 'ACDE', then the C and C would have to be matched as well. +You can provide an argument, which will be available in the var $REGMARK +after the match completes. + =back =back diff --git a/pod/perlrecharclass.pod b/pod/perlrecharclass.pod index f46de4c..ef8048f 100644 --- a/pod/perlrecharclass.pod +++ b/pod/perlrecharclass.pod @@ -1051,8 +1051,9 @@ C<\N{...}>, etc.) This last example shows the use of this construct to specify an ordinary bracketed character class without additional set operations. Note the -white space within it; Cx> is turned on even within bracketed -character classes, except you can't have comments inside them. Hence, +white space within it; a limited version of Cx> is turned on even +within bracketed character classes, with only the SPACE and TAB (C<\t>) +characters allowed, and no comments. Hence, (?[ [#] ]) diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 4a3e6fd..78de284 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -319,7 +319,8 @@ disabled. The signature is part of a subroutine's body. Normally the body of a subroutine is simply a braced block of code. When using a signature, the signature is a parenthesised list that goes immediately after -the subroutine name. The signature declares lexical variables that are +the subroutine name (or, for anonymous subroutines, immediately after +the C keyword). The signature declares lexical variables that are in scope for the block. When the subroutine is called, the signature takes control first. It populates the signature variables from the list of arguments that were passed. If the argument list doesn't meet diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod index f29f7aa..01425d2 100644 --- a/pod/perlsyn.pod +++ b/pod/perlsyn.pod @@ -685,13 +685,8 @@ and 5.16, under those implementations the version of C<$_> governed by C is merely a lexically scoped copy of the original, not a dynamically scoped alias to the original, as it would be if it were a C or under both the original and the current Perl 6 language -specification. This bug was fixed in Perl -5.18. If you really want a lexical C<$_>, -specify that explicitly, but note that C -is now deprecated and will warn unless warnings -have been disabled: - - given(my $_ = EXPR) { ... } +specification. This bug was fixed in Perl 5.18 (and lexicalized C<$_> itself +was removed in Perl 5.24). If your code still needs to run on older versions, stick to C for your topicalizer and diff --git a/pod/perltie.pod b/pod/perltie.pod index a200acc..db01b44 100644 --- a/pod/perltie.pod +++ b/pod/perltie.pod @@ -765,8 +765,7 @@ hash element for this: X This method will be triggered when the user is going -to iterate through the hash, such as via a keys() or each() -call. +to iterate through the hash, such as via a keys(), values(), or each() call. sub FIRSTKEY { carp &whowasi if $DEBUG; @@ -775,14 +774,22 @@ call. each %{$self->{LIST}} } +FIRSTKEY is always called in scalar context and it should just +return the first key. values(), and each() in list context, +will call FETCH for the returned keys. + =item NEXTKEY this, lastkey X -This method gets triggered during a keys() or each() iteration. It has a +This method gets triggered during a keys(), values(), or each() iteration. It has a second argument which is the last key that had been accessed. This is -useful if you're carrying about ordering or calling the iterator from more +useful if you're caring about ordering or calling the iterator from more than one sequence, or not really storing things in a hash anywhere. +NEXTKEY is always called in scalar context and it should just +return the next key. values(), and each() in list context, +will call FETCH for the returned keys. + For our example, we're using a real hash so we'll do just the simple thing, but we'll have to go through the LIST field indirectly. diff --git a/pod/perlvar.pod b/pod/perlvar.pod index 005f23e..f5922ad 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -1820,10 +1820,12 @@ Each element of C<%!> has a true value only if C<$!> is set to that value. For example, C<$!{ENOENT}> is true if and only if the current value of C<$!> is C; that is, if the most recent error was "No such file or directory" (or its moral equivalent: not all operating -systems give that exact error, and certainly not all languages). To -check if a particular key is meaningful on your system, use C; for a list of legal keys, use C. See L -for more information, and also see L. +systems give that exact error, and certainly not all languages). The +specific true value is not guaranteed, but in the past has generally +been the numeric value of C<$!>. To check if a particular key is +meaningful on your system, use C; for a list of legal +keys, use C. See L for more information, and also see +L. This variable was added in Perl 5.005. diff --git a/pp.c b/pp.c index 9dd3048..b084d49 100644 --- a/pp.c +++ b/pp.c @@ -88,18 +88,18 @@ PP(pp_padav) gimme = GIMME_V; if (gimme == G_ARRAY) { /* XXX see also S_pushav in pp_hot.c */ - const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; + const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; EXTEND(SP, maxarg); if (SvMAGICAL(TARG)) { - Size_t i; + SSize_t i; for (i=0; i < maxarg; i++) { SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE); SP[i+1] = (svp) ? *svp : &PL_sv_undef; } } else { - PADOFFSET i; - for (i=0; i < (PADOFFSET)maxarg; i++) { + SSize_t i; + for (i=0; i < maxarg; i++) { SV * const sv = AvARRAY((const AV *)TARG)[i]; SP[i+1] = sv ? sv : &PL_sv_undef; } @@ -762,7 +762,8 @@ PP(pp_trans) PUSHs(newsv); } else { - mPUSHi(do_trans(sv)); + I32 i = do_trans(sv); + mPUSHi(i); } RETURN; } @@ -1393,7 +1394,17 @@ PP(pp_multiply) NV right = SvNV_nomg(svr); NV left = SvNV_nomg(svl); (void)POPs; +#if defined(__sgi) && defined(USE_LONG_DOUBLE) && LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN && NVSIZE == 16 + { + NV result = left * right; + if (Perl_isinf(result)) { + Zero((U8*)&result + 8, 8, U8); + } + SETn( result ); + } +#else SETn( left * right ); +#endif RETURN; } } @@ -1718,14 +1729,15 @@ PP(pp_repeat) if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; - const Size_t items = SP - MARK; + const SSize_t items = SP - MARK; const U8 mod = PL_op->op_flags & OPf_MOD; if (count > 1) { - Size_t max; + SSize_t max; - if ( items > MEM_SIZE_MAX / (UV)count /* max would overflow */ - || items > (U32)I32_MAX / sizeof(SV *) /* repeatcpy would overflow */ + if ( items > SSize_t_MAX / count /* max would overflow */ + /* repeatcpy would overflow */ + || items > I32_MAX / (I32)sizeof(SV *) ) Perl_croak(aTHX_ "%s","Out of memory during list extend"); max = items * count; @@ -1746,7 +1758,7 @@ PP(pp_repeat) SP += max; } else if (count <= 0) - SP -= items; + SP = MARK; } else { /* Note: mark already snarfed by pp_list */ SV * const tmpstr = POPs; @@ -5441,6 +5453,10 @@ PP(pp_push) /* SPAGAIN; not needed: SP is assigned to immediately below */ } else { + /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we + * only need to save locally, not on the save stack */ + U16 old_delaymagic = PL_delaymagic; + if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify(); PL_delaymagic = DM_DELAY; for (++MARK; MARK <= SP; MARK++) { @@ -5453,8 +5469,7 @@ PP(pp_push) } if (PL_delaymagic & DM_ARRAY_ISA) mg_set(MUTABLE_SV(ary)); - - PL_delaymagic = 0; + PL_delaymagic = old_delaymagic; } SP = ORIGMARK; if (OP_GIMME(PL_op, 0) != G_VOID) { @@ -5494,12 +5509,20 @@ PP(pp_unshift) /* SPAGAIN; not needed: SP is assigned to immediately below */ } else { + /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we + * only need to save locally, not on the save stack */ + U16 old_delaymagic = PL_delaymagic; SSize_t i = 0; + av_unshift(ary, SP - MARK); + PL_delaymagic = DM_DELAY; while (MARK < SP) { SV * const sv = newSVsv(*++MARK); (void)av_store(ary, i++, sv); } + if (PL_delaymagic & DM_ARRAY_ISA) + mg_set(MUTABLE_SV(ary)); + PL_delaymagic = old_delaymagic; } SP = ORIGMARK; if (OP_GIMME(PL_op, 0) != G_VOID) { @@ -5596,7 +5619,7 @@ PP(pp_reverse) if (SP - MARK > 1) do_join(TARG, &PL_sv_no, MARK, SP); else { - sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv()); + sv_setsv(TARG, SP > MARK ? *SP : DEFSV); } up = SvPV_force(TARG, len); @@ -5660,7 +5683,7 @@ PP(pp_split) SSize_t maxiters = slen + 10; I32 trailing_empty = 0; const char *orig; - const I32 origlimit = limit; + const IV origlimit = limit; I32 realarray = 0; I32 base; const I32 gimme = GIMME_V; @@ -5834,11 +5857,13 @@ PP(pp_split) split //, $str, $i; */ if (!gimme_scalar) { - const U32 items = limit - 1; - if (items < slen) + const IV items = limit - 1; + /* setting it to -1 will trigger a panic in EXTEND() */ + const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen; + if (items >=0 && items < sslen) EXTEND(SP, items); else - EXTEND(SP, slen); + EXTEND(SP, sslen); } if (do_utf8) { @@ -6183,10 +6208,7 @@ PP(pp_coreargs) case OA_SCALAR: try_defsv: if (!numargs && defgv && whicharg == minargs + 1) { - PUSHs(find_rundefsv2( - find_runcv_where(FIND_RUNCV_level_eq, 1, NULL), - cxstack[cxstack_ix].blk_oldcop->cop_seq - )); + PUSHs(DEFSV); } else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL); break; diff --git a/pp.h b/pp.h index 2d99a72..b497085 100644 --- a/pp.h +++ b/pp.h @@ -283,29 +283,58 @@ Does not use C. See also C>, C> and C>. =cut */ +/* _EXTEND_SAFE_N(n): private helper macro for EXTEND(). + * Tests whether the value of n would be truncated when implicitly cast to + * SSize_t as an arg to stack_grow(). If so, sets it to -1 instead to + * trigger a panic. It will be constant folded on platforms where this + * can't happen. + */ + +#define _EXTEND_SAFE_N(n) \ + (sizeof(n) > sizeof(SSize_t) && ((SSize_t)(n) != (n)) ? -1 : (n)) + #ifdef STRESS_REALLOC # define EXTEND(p,n) STMT_START { \ - sp = stack_grow(sp,p,(SSize_t) (n)); \ + sp = stack_grow(sp,p,_EXTEND_SAFE_N(n)); \ PERL_UNUSED_VAR(sp); \ } STMT_END /* Same thing, but update mark register too. */ # define MEXTEND(p,n) STMT_START { \ const SSize_t markoff = mark - PL_stack_base; \ - sp = stack_grow(sp,p,(SSize_t) (n)); \ + sp = stack_grow(sp,p,_EXTEND_SAFE_N(n)); \ mark = PL_stack_base + markoff; \ PERL_UNUSED_VAR(sp); \ } STMT_END #else -# define EXTEND(p,n) STMT_START { \ - if (UNLIKELY(PL_stack_max - p < (SSize_t)(n))) { \ - sp = stack_grow(sp,p,(SSize_t) (n)); \ + +/* _EXTEND_NEEDS_GROW(p,n): private helper macro for EXTEND(). + * Tests to see whether n is too big and we need to grow the stack. Be + * very careful if modifying this. There are many ways to get things wrong + * (wrapping, truncating etc) that could cause a false negative and cause + * the call to stack_grow() to be skipped. On the other hand, false + * positives are safe. + * Bear in mind that sizeof(p) may be less than, equal to, or greater + * than sizeof(n), and while n is documented to be signed, someone might + * pass an unsigned value or expression. In general don't use casts to + * avoid warnings; instead expect the caller to fix their code. + * It is legal for p to be greater than PL_stack_max. + * If the allocated stack is already very large but current usage is + * small, then PL_stack_max - p might wrap round to a negative value, but + * this just gives a safe false positive + */ + +# define _EXTEND_NEEDS_GROW(p,n) ( (n) < 0 || PL_stack_max - p < (n)) + +# define EXTEND(p,n) STMT_START { \ + if (UNLIKELY(_EXTEND_NEEDS_GROW(p,n))) { \ + sp = stack_grow(sp,p,_EXTEND_SAFE_N(n)); \ PERL_UNUSED_VAR(sp); \ } } STMT_END /* Same thing, but update mark register too. */ -# define MEXTEND(p,n) STMT_START { \ - if (UNLIKELY(PL_stack_max - p < (SSize_t)(n))) { \ - const SSize_t markoff = mark - PL_stack_base; \ - sp = stack_grow(sp,p,(SSize_t) (n)); \ +# define MEXTEND(p,n) STMT_START { \ + if (UNLIKELY(_EXTEND_NEEDS_GROW(p,n))) { \ + const SSize_t markoff = mark - PL_stack_base;\ + sp = stack_grow(sp,p,_EXTEND_SAFE_N(n)); \ mark = PL_stack_base + markoff; \ PERL_UNUSED_VAR(sp); \ } } STMT_END diff --git a/pp_ctl.c b/pp_ctl.c index 852ec36..cdbdbd0 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -940,10 +940,7 @@ PP(pp_grepstart) ENTER_with_name("grep"); /* enter outer scope */ SAVETMPS; - if (PL_op->op_private & OPpGREP_LEX) - SAVESPTR(PAD_SVl(PL_op->op_targ)); - else - SAVE_DEFSV; + SAVE_DEFSV; ENTER_with_name("grep_item"); /* enter inner scope */ SAVEVPTR(PL_curpm); @@ -953,10 +950,7 @@ PP(pp_grepstart) PL_tmps_floor++; } SvTEMP_off(src); - if (PL_op->op_private & OPpGREP_LEX) - PAD_SVl(PL_op->op_targ) = src; - else - DEFSV_set(src); + DEFSV_set(src); PUTBACK; if (PL_op->op_type == OP_MAPSTART) @@ -1078,15 +1072,8 @@ PP(pp_mapwhile) (void)POPMARK; /* pop dst */ SP = PL_stack_base + POPMARK; /* pop original mark */ if (gimme == G_SCALAR) { - if (PL_op->op_private & OPpGREP_LEX) { - SV* sv = sv_newmortal(); - sv_setiv(sv, items); - PUSHs(sv); - } - else { dTARGET; XPUSHi(items); - } } else if (gimme == G_ARRAY) SP += items; @@ -1104,10 +1091,7 @@ PP(pp_mapwhile) src = sv_mortalcopy(src); } SvTEMP_off(src); - if (PL_op->op_private & OPpGREP_LEX) - PAD_SVl(PL_op->op_targ) = src; - else - DEFSV_set(src); + DEFSV_set(src); RETURNOP(cLOGOP->op_other); } @@ -3497,11 +3481,14 @@ S_check_type_and_open(pTHX_ SV *name) /* checking here captures a reasonable error message when * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the * user gets a confusing message about looking for the .pmc file - * rather than for the .pm file. + * rather than for the .pm file so do the check in S_doopen_pm when + * PMC is on instead of here. S_doopen_pm calls this func. * This check prevents a \0 in @INC causing problems. */ +#ifdef PERL_DISABLE_PMC if (!IS_SAFE_PATHNAME(p, len, "require")) return NULL; +#endif /* on Win32 stat is expensive (it does an open() and close() twice and a couple other IO calls), the open will fail with a dir on its own with @@ -3557,13 +3544,14 @@ S_doopen_pm(pTHX_ SV *name) if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) { SV *const pmcsv = sv_newmortal(); - Stat_t pmcstat; + PerlIO * pmcio; SvSetSV_nosteal(pmcsv,name); sv_catpvs(pmcsv, "c"); - if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0) - return check_type_and_open(pmcsv); + pmcio = check_type_and_open(pmcsv); + if (pmcio) + return pmcio; } return check_type_and_open(name); } @@ -4356,15 +4344,9 @@ PP(pp_entergiven) ENTER_with_name("given"); SAVETMPS; - if (PL_op->op_targ) { - SAVEPADSVANDMORTALIZE(PL_op->op_targ); - SvREFCNT_dec(PAD_SVl(PL_op->op_targ)); - PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs); - } - else { - SAVE_DEFSV; - DEFSV_set(POPs); - } + assert(!PL_op->op_targ); /* used to be set for lexical $_ */ + SAVE_DEFSV; + DEFSV_set(POPs); PUSHBLOCK(cx, CXt_GIVEN, SP); PUSHGIVEN(cx); diff --git a/pp_hot.c b/pp_hot.c index bed0a27..e866841 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1174,6 +1174,9 @@ PP(pp_aassign) SSize_t i; int magic; U32 lval; + /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we + * only need to save locally, not on the save stack */ + U16 old_delaymagic = PL_delaymagic; #ifdef DEBUGGING bool fake = 0; #endif @@ -1275,7 +1278,9 @@ PP(pp_aassign) } av_clear(ary); - av_extend(ary, lastrelem - relem); + if (relem <= lastrelem) + av_extend(ary, lastrelem - relem); + i = 0; while (relem <= lastrelem) { /* gobble up all the rest */ SV **didstore; @@ -1543,7 +1548,7 @@ PP(pp_aassign) PERL_UNUSED_VAR(tmp_egid); #endif } - PL_delaymagic = 0; + PL_delaymagic = old_delaymagic; if (gimme == G_VOID) SP = firstrelem - 1; @@ -1962,6 +1967,7 @@ Perl_do_readline(pTHX) XPUSHs(sv); if (type == OP_GLOB) { const char *t1; + Stat_t statbuf; if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { char * const tmps = SvEND(sv) - 1; @@ -1977,7 +1983,7 @@ Perl_do_readline(pTHX) if (strchr("$&*(){}[]'\";\\|?<>~`", *t1)) #endif break; - if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) { + if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) { (void)POPs; /* Unmatched wildcard? Chuck it... */ continue; } @@ -3137,15 +3143,8 @@ PP(pp_grepwhile) (void)POPMARK; /* pop dst */ SP = PL_stack_base + POPMARK; /* pop original mark */ if (gimme == G_SCALAR) { - if (PL_op->op_private & OPpGREP_LEX) { - SV* const sv = sv_newmortal(); - sv_setiv(sv, items); - PUSHs(sv); - } - else { dTARGET; XPUSHi(items); - } } else if (gimme == G_ARRAY) SP += items; @@ -3163,10 +3162,7 @@ PP(pp_grepwhile) PL_tmps_floor++; } SvTEMP_off(src); - if (PL_op->op_private & OPpGREP_LEX) - PAD_SVl(PL_op->op_targ) = src; - else - DEFSV_set(src); + DEFSV_set(src); RETURNOP(cLOGOP->op_other); } @@ -3434,7 +3430,8 @@ PP(pp_entersub) SAVETMPS; if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && !CvLVALUE(cv))) - DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf, + SVfARG(cv_name(cv, NULL, 0))); /* warning must come *after* we fully set up the context * stuff so that __WARN__ handlers can safely dounwind() * if they want to @@ -3455,7 +3452,8 @@ PP(pp_entersub) & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub) ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && !CvLVALUE(cv))) - DIE(aTHX_ "Can't modify non-lvalue subroutine call"); + DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf, + SVfARG(cv_name(cv, NULL, 0))); if (UNLIKELY(!hasargs && GvAV(PL_defgv))) { /* Need to copy @_ to stack. Alternative may be to diff --git a/pp_sys.c b/pp_sys.c index f1e2902..2ad44a0 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -533,6 +533,7 @@ Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, { SV **orig_sp = sp; I32 ret_args; + SSize_t extend_size; PERL_ARGS_ASSERT_TIED_METHOD; @@ -543,7 +544,12 @@ Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */ PUSHSTACKi(PERLSI_MAGIC); - EXTEND(SP, argc+1); /* object + args */ + /* extend for object + args. If argc might wrap/truncate when cast + * to SSize_t, set to -1 which will trigger a panic in EXTEND() */ + extend_size = + sizeof(argc) >= sizeof(SSize_t) && argc > SSize_t_MAX - 1 + ? -1 : (SSize_t)argc + 1; + EXTEND(SP, extend_size); PUSHMARK(sp); PUSHs(SvTIED_obj(sv, mg)); if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) { @@ -3720,17 +3726,20 @@ PP(pp_rename) { dSP; dTARGET; int anum; +#ifndef HAS_RENAME + Stat_t statbuf; +#endif const char * const tmps2 = POPpconstx; const char * const tmps = SvPV_nolen_const(TOPs); TAINT_PROPER("rename"); #ifdef HAS_RENAME anum = PerlLIO_rename(tmps, tmps2); #else - if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) { + if (!(anum = PerlLIO_stat(tmps, &statbuf))) { if (same_dirent(tmps2, tmps)) /* can always rename to same name */ anum = 1; else { - if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode)) + if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode)) (void)UNLINK(tmps2); if (!(anum = link(tmps, tmps2))) anum = UNLINK(tmps); @@ -3892,7 +3901,8 @@ S_dooneliner(pTHX_ const char *cmd, const char *filename) return 0; } else { /* some mkdirs return no failure indication */ - anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0); + Stat_t statbuf; + anum = (PerlLIO_stat(save_filename, &statbuf) >= 0); if (PL_op->op_type == OP_RMDIR) anum = !anum; if (anum) diff --git a/proto.h b/proto.h index 6d49f47..7d7fe88 100644 --- a/proto.h +++ b/proto.h @@ -860,9 +860,6 @@ PERL_CALLCONV CV* Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) __attribute__warn_unused_result__; PERL_CALLCONV SV* Perl_find_rundefsv(pTHX); -PERL_CALLCONV SV* Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq); -#define PERL_ARGS_ASSERT_FIND_RUNDEFSV2 \ - assert(cv) PERL_CALLCONV PADOFFSET Perl_find_rundefsvoffset(pTHX) __attribute__deprecated__; @@ -2900,7 +2897,7 @@ PERL_CALLCONV char* Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp); PERL_CALLCONV UV Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags); #define PERL_ARGS_ASSERT_SV_2UV_FLAGS \ assert(sv) -PERL_CALLCONV int Perl_sv_backoff(SV *const sv); +PERL_CALLCONV void Perl_sv_backoff(SV *const sv); #define PERL_ARGS_ASSERT_SV_BACKOFF \ assert(sv) PERL_CALLCONV SV* Perl_sv_bless(pTHX_ SV *const sv, HV *const stash); @@ -4733,7 +4730,7 @@ STATIC U32 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_ STATIC I32 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth); #define PERL_ARGS_ASSERT_MAKE_TRIE \ assert(pRExC_state); assert(startbranch); assert(first); assert(last); assert(tail) -STATIC char * S_nextchar(pTHX_ RExC_state_t *pRExC_state); +STATIC void S_nextchar(pTHX_ RExC_state_t *pRExC_state); #define PERL_ARGS_ASSERT_NEXTCHAR \ assert(pRExC_state) STATIC void S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state); @@ -4786,11 +4783,6 @@ STATIC void S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U STATIC regnode* S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_len, const char* const name); #define PERL_ARGS_ASSERT_REGNODE_GUTS \ assert(pRExC_state); assert(name) -STATIC char * S_regpatws(RExC_state_t *pRExC_state, char *p, const bool recognize_comment) - __attribute__warn_unused_result__; -#define PERL_ARGS_ASSERT_REGPATWS \ - assert(pRExC_state); assert(p) - STATIC regnode* S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth); #define PERL_ARGS_ASSERT_REGPIECE \ assert(pRExC_state); assert(flagp) @@ -4806,6 +4798,9 @@ STATIC void S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, struct scan_dat STATIC void S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, regnode* const node, SV* const cp_list, SV* const runtime_defns, SV* const only_utf8_locale_list, SV* const swash, const bool has_user_defined_property); #define PERL_ARGS_ASSERT_SET_ANYOF_ARG \ assert(pRExC_state); assert(node) +STATIC void S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state, char ** p, const bool force_to_xmod); +#define PERL_ARGS_ASSERT_SKIP_TO_BE_IGNORED_TEXT \ + assert(pRExC_state); assert(p) PERL_STATIC_INLINE void S_ssc_add_range(pTHX_ regnode_ssc *ssc, UV const start, UV const end); #define PERL_ARGS_ASSERT_SSC_ADD_RANGE \ assert(ssc) @@ -5052,7 +5047,7 @@ STATIC I32 S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, r #define PERL_ARGS_ASSERT_REGREPEAT \ assert(prog); assert(startposp); assert(p); assert(reginfo) -STATIC I32 S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) +STATIC bool S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) __attribute__warn_unused_result__; #define PERL_ARGS_ASSERT_REGTRY \ assert(reginfo); assert(startposp) diff --git a/regcharclass.h b/regcharclass.h index ab653ae..f9ef088 100644 --- a/regcharclass.h +++ b/regcharclass.h @@ -2514,7 +2514,7 @@ * 1a0687fb9c6c4567e853913549df0944fe40821279a3e9cdaa6ab8679bc286fd lib/unicore/extracted/DLineBreak.txt * 40bcfed3ca727c19e1331f6c33806231d5f7eeeabd2e6a9e06a3740c85d0c250 lib/unicore/extracted/DNumType.txt * a18d502bad39d527ac5586d7bc93e29f565859e3bcc24ada627eff606d6f5fed lib/unicore/extracted/DNumValues.txt - * 00c1bda0498082b8245a27cca31028ec97b90ad717b00281ea023d25e11428f1 lib/unicore/mktables + * 6096850989ab3bc78543045021ede0b02708937b5b0f860991a0ac0373552d02 lib/unicore/mktables * 462c9aaa608fb2014cd9649af1c5c009485c60b9c8b15b89401fdc10cf6161c6 lib/unicore/version * c6884f4d629f04d1316f3476cb1050b6a1b98ca30c903262955d4eae337c6b1e regen/charset_translations.pl * d9c04ac46bdd81bb3e26519f2b8eb6242cb12337205add3f7cf092b0c58dccc4 regen/regcharclass.pl diff --git a/regcomp.c b/regcomp.c index 4f4bb44..611cc1c 100644 --- a/regcomp.c +++ b/regcomp.c @@ -661,7 +661,7 @@ static const scan_data_t zero_scan_data = } STMT_END /* A specialized version of vFAIL2 that works with UTF8f */ -#define vFAIL2utf8f(m, a1) STMT_START { \ +#define vFAIL2utf8f(m, a1) STMT_START { \ const IV offset = RExC_parse - RExC_precomp; \ if (!SIZE_ONLY) \ SAVEFREESV(RExC_rx_sv); \ @@ -669,6 +669,14 @@ static const scan_data_t zero_scan_data = REPORT_LOCATION_ARGS(offset)); \ } STMT_END +#define vFAIL3utf8f(m, a1, a2) STMT_START { \ + const IV offset = RExC_parse - RExC_precomp; \ + if (!SIZE_ONLY) \ + SAVEFREESV(RExC_rx_sv); \ + S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, \ + REPORT_LOCATION_ARGS(offset)); \ +} STMT_END + /* These have asserts in them because of [perl #122671] Many warnings in * regcomp.c can occur twice. If they get output in pass1 and later in that * pass, the pattern has to be converted to UTF-8 and the pass restarted, they @@ -9860,9 +9868,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) STRLEN verb_len = 0; char *start_arg = NULL; unsigned char op = 0; - int argok = 1; - int internal_argval = 0; /* internal_argval is only useful if - !argok */ + int arg_required = 0; + int internal_argval = -1; /* if >-1 we are not allowed an argument*/ if (has_intervening_patws) { RExC_parse++; @@ -9904,14 +9911,13 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) case 'F': /* (*FAIL) */ if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) { op = OPFAIL; - argok = 0; } break; case ':': /* (*:NAME) */ case 'M': /* (*MARK:NAME) */ if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) { op = MARKPOINT; - argok = -1; + arg_required = 1; } break; case 'P': /* (*PRUNE) */ @@ -9936,36 +9942,30 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) "Unknown verb pattern '%"UTF8f"'", UTF8fARG(UTF, verb_len, start_verb)); } - if ( argok ) { - if ( start_arg && internal_argval ) { - vFAIL3("Verb pattern '%.*s' may not have an argument", - verb_len, start_verb); - } else if ( argok < 0 && !start_arg ) { - vFAIL3("Verb pattern '%.*s' has a mandatory argument", - verb_len, start_verb); - } else { - ret = reganode(pRExC_state, op, internal_argval); - if ( ! internal_argval && ! SIZE_ONLY ) { - if (start_arg) { - SV *sv = newSVpvn( start_arg, - RExC_parse - start_arg); - ARG(ret) = add_data( pRExC_state, - STR_WITH_LEN("S")); - RExC_rxi->data->data[ARG(ret)]=(void*)sv; - ret->flags = 0; - } else { - ret->flags = 1; - } - } - } - if (!internal_argval) - RExC_seen |= REG_VERBARG_SEEN; - } else if ( start_arg ) { - vFAIL3("Verb pattern '%.*s' may not have an argument", - verb_len, start_verb); - } else { - ret = reg_node(pRExC_state, op); - } + if ( arg_required && !start_arg ) { + vFAIL3("Verb pattern '%.*s' has a mandatory argument", + verb_len, start_verb); + } + if (internal_argval == -1) { + ret = reganode(pRExC_state, op, 0); + } else { + ret = reg2Lanode(pRExC_state, op, 0, internal_argval); + } + RExC_seen |= REG_VERBARG_SEEN; + if ( ! SIZE_ONLY ) { + if (start_arg) { + SV *sv = newSVpvn( start_arg, + RExC_parse - start_arg); + ARG(ret) = add_data( pRExC_state, + STR_WITH_LEN("S")); + RExC_rxi->data->data[ARG(ret)]=(void*)sv; + ret->flags = 1; + } else { + ret->flags = 0; + } + if ( internal_argval != -1 ) + ARG2L_SET(ret, internal_argval); + } nextchar(pRExC_state); return ret; } @@ -10125,10 +10125,10 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) case '!': /* (?!...) */ RExC_seen_zerolen++; /* check if we're really just a "FAIL" assertion */ - --RExC_parse; - nextchar(pRExC_state); + skip_to_be_ignored_text(pRExC_state, &RExC_parse, + FALSE /* Don't force to /x */ ); if (*RExC_parse == ')') { - ret=reg_node(pRExC_state, OPFAIL); + ret=reganode(pRExC_state, OPFAIL, 0); nextchar(pRExC_state); return ret; } @@ -10331,9 +10331,12 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) int is_define= 0; const int DEFINE_len = sizeof("DEFINE") - 1; if (RExC_parse[0] == '?') { /* (?(?...)) */ - if (RExC_parse[1] == '=' || RExC_parse[1] == '!' - || RExC_parse[1] == '<' - || RExC_parse[1] == '{') { /* Lookahead or eval. */ + if ( + RExC_parse[1] == '=' || + RExC_parse[1] == '!' || + RExC_parse[1] == '<' || + RExC_parse[1] == '{' + ) { /* Lookahead or eval. */ I32 flag; regnode *tail; @@ -10407,7 +10410,6 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) { /* (?(1)...) */ char c; - char *tmp; UV uv; if (grok_atoUV(RExC_parse, &uv, &endptr) && uv <= I32_MAX @@ -10415,18 +10417,17 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) parno = (I32)uv; RExC_parse = (char*)endptr; } - /* XXX else what? */ + else { + vFAIL("panic: grok_atoUV returned FALSE"); + } ret = reganode(pRExC_state, GROUPP, parno); insert_if_check_paren: - if (*(tmp = nextchar(pRExC_state)) != ')') { - /* nextchar also skips comments, so undo its work - * and skip over the the next character. - */ - RExC_parse = tmp; + if (UCHARAT(RExC_parse) != ')') { RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1; vFAIL("Switch condition not recognized"); } + nextchar(pRExC_state); insert_if: REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0)); br = regbranch(pRExC_state, &flags, 1,depth+1); @@ -10440,7 +10441,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } else REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0)); - c = *nextchar(pRExC_state); + c = UCHARAT(RExC_parse); + nextchar(pRExC_state); if (flags&HASWIDTH) *flagp |= HASWIDTH; if (c == '|') { @@ -10461,7 +10463,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) REGTAIL(pRExC_state, ret, lastbr); if (flags&HASWIDTH) *flagp |= HASWIDTH; - c = *nextchar(pRExC_state); + c = UCHARAT(RExC_parse); + nextchar(pRExC_state); } else lastbr = NULL; @@ -10734,10 +10737,11 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if (DEPENDS_SEMANTICS && RExC_uni_semantics) { set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET); } - if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') { + if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') { RExC_parse = oregcomp_parse; vFAIL("Unmatched ("); } + nextchar(pRExC_state); } else if (!paren && RExC_parse < RExC_end) { if (*RExC_parse == ')') { @@ -10794,8 +10798,8 @@ S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) *flagp = WORST; /* Tentatively. */ - RExC_parse--; - nextchar(pRExC_state); + skip_to_be_ignored_text(pRExC_state, &RExC_parse, + FALSE /* Don't force to /x */ ); while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') { flags &= ~TRYAGAIN; latest = regpiece(pRExC_state, &flags,depth+1); @@ -10936,13 +10940,13 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * enough space for all the things we are about to throw * away, but we can shrink it by the ammount we are about * to re-use here */ - RExC_size = PREVOPER(RExC_size) - regarglen[(U8)OPFAIL]; + RExC_size += PREVOPER(RExC_size) - regarglen[(U8)OPFAIL]; } else { ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match"); RExC_emit = orig_emit; } - ret = reg_node(pRExC_state, OPFAIL); + ret = reganode(pRExC_state, OPFAIL, 0); return ret; } else if (min == max && RExC_parse < RExC_end && *RExC_parse == '?') @@ -10952,8 +10956,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) "Useless use of greediness modifier '%c'", *RExC_parse); } - /* Absorb the modifier, so later code doesn't see nor use - * it */ + /* Absorb the modifier, so later code doesn't see nor use it */ nextchar(pRExC_state); } @@ -11153,13 +11156,13 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, * sequence. *node_p * will be set to a generated node returned by this * function calling S_reg(). * - * The final possibility, which happens is that it is premature to be calling - * this function; that pass1 needs to be restarted. This can happen when this - * changes from /d to /u rules, or when the pattern needs to be upgraded to - * UTF-8. The latter occurs only when the fourth possibility would otherwise - * be in effect, and is because one of those code points requires the - * pattern to be recompiled as UTF-8. The function returns FALSE, and sets - * the RESTART_PASS1 and NEED_UTF8 flags in *flagp, as appropriate. When this + * The final possibility is that it is premature to be calling this function; + * that pass1 needs to be restarted. This can happen when this changes from + * /d to /u rules, or when the pattern needs to be upgraded to UTF-8. The + * latter occurs only when the fourth possibility would otherwise be in + * effect, and is because one of those code points requires the pattern to be + * recompiled as UTF-8. The function returns FALSE, and sets the + * RESTART_PASS1 and NEED_UTF8 flags in *flagp, as appropriate. When this * happens, the caller needs to desist from continuing parsing, and return * this information to its caller. This is not set for when there is only one * code point, as this can be called as part of an ANYOF node, and they can @@ -11178,14 +11181,12 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, * parser. But if the single-quoted regex is something like '\N{U+41}', that * is legal and handled here. The code point is Unicode, and has to be * translated into the native character set for non-ASCII platforms. - * the tokenizer passes the \N sequence through unchanged; this code will not - * attempt to determine this nor expand those, instead raising a syntax error. */ char * endbrace; /* points to '}' following the name */ char *endchar; /* Points to '.' or '}' ending cur char in the input stream */ - char* p; /* Temporary */ + char* p = RExC_parse; /* Temporary */ GET_RE_DEBUG_FLAGS_DECL; @@ -11203,14 +11204,12 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, /* The [^\n] meaning of \N ignores spaces and comments under the /x * modifier. The other meanings do not, so use a temporary until we find * out which we are being called with */ - p = (RExC_flags & RXf_PMf_EXTENDED) - ? regpatws(pRExC_state, RExC_parse, - TRUE) /* means recognize comments */ - : RExC_parse; + skip_to_be_ignored_text(pRExC_state, &p, + FALSE /* Don't force to /x */ ); /* Disambiguate between \N meaning a named character versus \N meaning * [^\n]. The latter is assumed when the {...} following the \N is a legal - * quantifier, or there is no a '{' at all */ + * quantifier, or there is no '{' at all */ if (*p != '{' || regcurly(p)) { RExC_parse = p; if (cp_count) { @@ -11220,9 +11219,7 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, if (! node_p) { return FALSE; } - RExC_parse--; /* Need to back off so nextchar() doesn't skip the - current char */ - nextchar(pRExC_state); + *node_p = reg_node(pRExC_state, REG_ANY); *flagp |= HASWIDTH|SIMPLE; MARK_NAUGHTY(1); @@ -11733,7 +11730,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) { regnode *ret = NULL; I32 flags = 0; - char *parse_start = RExC_parse; + char *parse_start; U8 op; int invert = 0; U8 arg; @@ -11747,6 +11744,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) PERL_ARGS_ASSERT_REGATOM; tryagain: + parse_start = RExC_parse; switch ((U8)*RExC_parse) { case '^': RExC_seen_zerolen++; @@ -12074,36 +12072,30 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) break; case 'p': case 'P': - { -#ifdef DEBUGGING - char* parse_start = RExC_parse - 2; -#endif + RExC_parse--; - RExC_parse--; - - ret = regclass(pRExC_state, flagp,depth+1, - TRUE, /* means just parse this element */ - FALSE, /* don't allow multi-char folds */ - FALSE, /* don't silence non-portable warnings. - It would be a bug if these returned - non-portables */ - (bool) RExC_strict, - TRUE, /* Allow an optimized regnode result */ - NULL); - if (*flagp & RESTART_PASS1) - return NULL; - /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if - * multi-char folds are allowed. */ - if (!ret) - FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"", - (UV) *flagp); + ret = regclass(pRExC_state, flagp,depth+1, + TRUE, /* means just parse this element */ + FALSE, /* don't allow multi-char folds */ + FALSE, /* don't silence non-portable warnings. It + would be a bug if these returned + non-portables */ + (bool) RExC_strict, + TRUE, /* Allow an optimized regnode result */ + NULL); + if (*flagp & RESTART_PASS1) + return NULL; + /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if + * multi-char folds are allowed. */ + if (!ret) + FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"", + (UV) *flagp); - RExC_parse--; + RExC_parse--; - Set_Node_Offset(ret, parse_start + 2); - Set_Node_Cur_Length(ret, parse_start); - nextchar(pRExC_state); - } + Set_Node_Offset(ret, parse_start); + Set_Node_Cur_Length(ret, parse_start - 2); + nextchar(pRExC_state); break; case 'N': /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the @@ -12132,7 +12124,9 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) if (*flagp & RESTART_PASS1) return NULL; - RExC_parse--; + + /* Here, evaluates to a single code point. Go get that */ + RExC_parse = parse_start; goto defchar; case 'k': /* Handle \k and \k'NAME' */ @@ -12248,6 +12242,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * octal character escape, e.g. \35 or \777. * The above logic should make it obvious why using * octal escapes in patterns is problematic. - Yves */ + RExC_parse = parse_start; goto defchar; } } @@ -12257,41 +12252,36 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * as an octal escape. It may or may not be a valid backref * escape. For instance \88888888 is unlikely to be a valid * backref. */ - { -#ifdef RE_TRACK_PATTERN_OFFSETS - char * const parse_start = RExC_parse - 1; /* MJD */ -#endif - while (isDIGIT(*RExC_parse)) - RExC_parse++; - if (hasbrace) { - if (*RExC_parse != '}') - vFAIL("Unterminated \\g{...} pattern"); - RExC_parse++; - } - if (!SIZE_ONLY) { - if (num > (I32)RExC_rx->nparens) - vFAIL("Reference to nonexistent group"); - } - RExC_sawback = 1; - ret = reganode(pRExC_state, - ((! FOLD) - ? REF - : (ASCII_FOLD_RESTRICTED) - ? REFFA - : (AT_LEAST_UNI_SEMANTICS) - ? REFFU - : (LOC) - ? REFFL - : REFF), - num); - *flagp |= HASWIDTH; + while (isDIGIT(*RExC_parse)) + RExC_parse++; + if (hasbrace) { + if (*RExC_parse != '}') + vFAIL("Unterminated \\g{...} pattern"); + RExC_parse++; + } + if (!SIZE_ONLY) { + if (num > (I32)RExC_rx->nparens) + vFAIL("Reference to nonexistent group"); + } + RExC_sawback = 1; + ret = reganode(pRExC_state, + ((! FOLD) + ? REF + : (ASCII_FOLD_RESTRICTED) + ? REFFA + : (AT_LEAST_UNI_SEMANTICS) + ? REFFU + : (LOC) + ? REFFL + : REFF), + num); + *flagp |= HASWIDTH; - /* override incorrect value set in reganode MJD */ - Set_Node_Offset(ret, parse_start+1); - Set_Node_Cur_Length(ret, parse_start); - RExC_parse--; - nextchar(pRExC_state); - } + /* override incorrect value set in reganode MJD */ + Set_Node_Offset(ret, parse_start); + Set_Node_Cur_Length(ret, parse_start-1); + skip_to_be_ignored_text(pRExC_state, &RExC_parse, + FALSE /* Don't force to /x */ ); } break; case '\0': @@ -12301,26 +12291,34 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) default: /* Do not generate "unrecognized" warnings here, we fall back into the quick-grab loop below */ - parse_start--; + RExC_parse = parse_start; goto defchar; - } + } /* end of switch on a \foo sequence */ break; case '#': - if (RExC_flags & RXf_PMf_EXTENDED) { + + /* '#' comments should have been spaced over before this function was + * called */ + assert((RExC_flags & RXf_PMf_EXTENDED) == 0); + /* + if (RExC_flags & RXf_PMf_EXTENDED) { RExC_parse = reg_skipcomment( pRExC_state, RExC_parse ); if (RExC_parse < RExC_end) goto tryagain; } + */ + /* FALLTHROUGH */ default: + defchar: { - parse_start = RExC_parse - 1; - - RExC_parse++; + /* Here, we have determined that the next thing is probably a + * literal character. RExC_parse points to the first byte of its + * definition. (It still may be an escape sequence that evaluates + * to a single character) */ - defchar: { STRLEN len = 0; UV ender = 0; char *p; @@ -12361,8 +12359,8 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) reparse: - /* We do the EXACTFish to EXACT node only if folding. (And we - * don't need to figure this out until pass 2) */ + /* We look for the EXACTFish to EXACT node optimizaton only if + * folding. (And we don't need to figure this out until pass 2) */ maybe_exact = FOLD && PASS2; /* XXX The node can hold up to 255 bytes, yet this only goes to @@ -12383,15 +12381,21 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * could back off to end with only a code point that isn't such a * non-final, but it is possible for there not to be any in the * entire node. */ - for (p = RExC_parse - 1; + + assert( ! UTF /* Is at the beginning of a character */ + || UTF8_IS_INVARIANT(UCHARAT(RExC_parse)) + || UTF8_IS_START(UCHARAT(RExC_parse))); + + for (p = RExC_parse; len < upper_parse && p < RExC_end; len++) { oldp = p; - if (RExC_flags & RXf_PMf_EXTENDED) - p = regpatws(pRExC_state, p, - TRUE); /* means recognize comments */ + /* White space has already been ignored */ + assert( (RExC_flags & RXf_PMf_EXTENDED) == 0 + || ! is_PATWS_safe((p), RExC_end, UTF)); + switch ((U8)*p) { case '^': case '$': @@ -12629,7 +12633,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) /* FALLTHROUGH */ default: if (!SIZE_ONLY&& isALPHANUMERIC(*p)) { - /* Include any { following the alpha to emphasize + /* Include any left brace following the alpha to emphasize * that it could be part of an escape at some point * in the future */ int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1; @@ -12641,7 +12645,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) case '{': /* Currently we don't warn when the lbrace is at the start * of a construct. This catches it in the middle of a - * literal string, or when its the first thing after + * literal string, or when it's the first thing after * something like "\b" */ if (! SIZE_ONLY && (len || (p > RExC_start && isALPHA_A(*(p -1))))) @@ -12663,12 +12667,13 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) } /* End of switch on the literal */ /* Here, have looked at the literal character and - * contains its ordinal,

points to the character after it - */ - - if ( RExC_flags & RXf_PMf_EXTENDED) - p = regpatws(pRExC_state, p, - TRUE); /* means recognize comments */ + * contains its ordinal,

points to the character after it. + * We need to check if the next non-ignored thing is a + * quantifier. Move

to after anything that should be + * ignored, which, as a side effect, positions

for the next + * loop iteration */ + skip_to_be_ignored_text(pRExC_state, &p, + FALSE /* Don't force to /x */ ); /* If the next thing is a quantifier, it applies to this * character only, which means that this character has to be in @@ -12677,12 +12682,16 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * the node, close the node with just them, and set up to do * this character again next time through, when it will be the * only thing in its new node */ - if ((next_is_quantifier = (p < RExC_end && ISMULT2(p))) && len) + if ((next_is_quantifier = ( LIKELY(p < RExC_end) + && UNLIKELY(ISMULT2(p)))) + && LIKELY(len)) { p = oldp; goto loopdone; } + /* Ready to add 'ender' to the node */ + if (! FOLD) { /* The simple case, just append the literal */ /* In the sizing pass, we need only the size of the @@ -13045,7 +13054,9 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) RExC_parse = p - 1; Set_Node_Cur_Length(ret, parse_start); - nextchar(pRExC_state); + RExC_parse = p; + skip_to_be_ignored_text(pRExC_state, &RExC_parse, + FALSE /* Don't force to /x */ ); { /* len is STRLEN which is unsigned, need to copy to signed */ IV iv = len; @@ -13060,29 +13071,6 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) return(ret); } -STATIC char * -S_regpatws(RExC_state_t *pRExC_state, char *p , const bool recognize_comment ) -{ - /* Returns the next non-pattern-white space, non-comment character (the - * latter only if 'recognize_comment is true) in the string p, which is - * ended by RExC_end. See also reg_skipcomment */ - const char *e = RExC_end; - - PERL_ARGS_ASSERT_REGPATWS; - - while (p < e) { - STRLEN len; - if ((len = is_PATWS_safe(p, e, UTF))) { - p += len; - } - else if (recognize_comment && *p == '#') { - p = reg_skipcomment(pRExC_state, p); - } - else - break; - } - return p; -} STATIC void S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr) @@ -13438,8 +13426,10 @@ S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, while (RExC_parse < RExC_end) { SV* current = NULL; - RExC_parse = regpatws(pRExC_state, RExC_parse, - TRUE); /* means recognize comments */ + + skip_to_be_ignored_text(pRExC_state, &RExC_parse, + TRUE /* Force /x */ ); + switch (*RExC_parse) { case '?': if (RExC_parse[1] == '[') depth++, RExC_parse++; @@ -13454,6 +13444,10 @@ S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, * default: case next time and keep on incrementing until * we find one of the invariants we do handle. */ RExC_parse++; + if (*RExC_parse == 'c') { + /* Skip the \cX notation for control characters */ + RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1; + } break; case '[': { @@ -13512,7 +13506,8 @@ S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, } goto no_close; } - RExC_parse++; + + RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1; } no_close: @@ -13614,9 +13609,8 @@ S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, operand */ SV* only_to_avoid_leaks; - /* Skip white space */ - RExC_parse = regpatws(pRExC_state, RExC_parse, - TRUE /* means recognize comments */ ); + skip_to_be_ignored_text(pRExC_state, &RExC_parse, + TRUE /* Force /x */ ); if (RExC_parse >= RExC_end) { Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'"); } @@ -13817,8 +13811,12 @@ redo_curchar: /* Having gotten rid of the fence, we pop the operand at the * stack top and process it as a newly encountered operand */ current = av_pop(stack); - assert(IS_OPERAND(current)); - goto handle_operand; + if (IS_OPERAND(current)) { + goto handle_operand; + } + + RExC_parse++; + goto bad_syntax; case '&': case '|': @@ -13894,10 +13892,16 @@ redo_curchar: /* Here, the new operator has equal or lower precedence than * what's already there. This means the operation already * there should be performed now, before the new one. */ + rhs = av_pop(stack); - lhs = av_pop(stack); + if (! IS_OPERAND(rhs)) { + + /* This can happen when a ! is not followed by an operand, + * like in /(?[\t &!])/ */ + goto bad_syntax; + } - assert(IS_OPERAND(rhs)); + lhs = av_pop(stack); assert(IS_OPERAND(lhs)); switch (stacked_operator) { @@ -14021,6 +14025,7 @@ redo_curchar: || SvTYPE(final) != SVt_INVLIST || av_tindex(stack) >= 0) /* More left on stack */ { + bad_syntax: SvREFCNT_dec(final); vFAIL("Incomplete expression within '(?[ ])'"); } @@ -14245,6 +14250,23 @@ S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN c #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION \ (SvCUR(listsv) != initial_listsv_len) +/* There is a restricted set of white space characters that are legal when + * ignoring white space in a bracketed character class. This generates the + * code to skip them. + * + * There is a line below that uses the same white space criteria but is outside + * this macro. Both here and there must use the same definition */ +#define SKIP_BRACKETED_WHITE_SPACE(do_skip, p) \ + STMT_START { \ + if (do_skip) { \ + while ( p < RExC_end \ + && isBLANK_A(UCHARAT(p))) \ + { \ + p++; \ + } \ + } \ + } STMT_END + STATIC regnode * S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, const bool stop_at_1, /* Just parse the next thing, don't @@ -14405,20 +14427,14 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated. */ } - if (skip_white) { - RExC_parse = regpatws(pRExC_state, RExC_parse, - FALSE /* means don't recognize comments */ ); - } + SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse); if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */ RExC_parse++; invert = TRUE; allow_multi_folds = FALSE; MARK_NAUGHTY(1); - if (skip_white) { - RExC_parse = regpatws(pRExC_state, RExC_parse, - FALSE /* means don't recognize comments */ ); - } + SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse); } /* Check that they didn't say [:posix:] instead of [[:posix:]] */ @@ -14455,10 +14471,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, break; } - if (skip_white) { - RExC_parse = regpatws(pRExC_state, RExC_parse, - FALSE /* means don't recognize comments */ ); - } + SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse); if (UCHARAT(RExC_parse) == ']') { break; @@ -14511,7 +14524,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * skipped, it means that that white space is wanted literally, and * is already in 'value'. Otherwise, need to translate the escape * into what it signifies. */ - if (! skip_white || ! is_PATWS_cp(value)) switch ((I32)value) { + if (! skip_white || ! isBLANK_A(value)) switch ((I32)value) { case 'w': namedclass = ANYOF_WORDCHAR; break; case 'W': namedclass = ANYOF_NWORDCHAR; break; @@ -14608,38 +14621,53 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, vFAIL2("Empty \\%c{}", (U8)value); if (*RExC_parse == '{') { const U8 c = (U8)value; - e = strchr(RExC_parse++, '}'); - if (!e) + e = strchr(RExC_parse, '}'); + if (!e) { + RExC_parse++; vFAIL2("Missing right brace on \\%c{}", c); - while (isSPACE(*RExC_parse)) - RExC_parse++; + } + + RExC_parse++; + while (isSPACE(*RExC_parse)) { + RExC_parse++; + } + + if (UCHARAT(RExC_parse) == '^') { + + /* toggle. (The rhs xor gets the single bit that + * differs between P and p; the other xor inverts just + * that bit) */ + value ^= 'P' ^ 'p'; + + RExC_parse++; + while (isSPACE(*RExC_parse)) { + RExC_parse++; + } + } + if (e == RExC_parse) vFAIL2("Empty \\%c{}", c); + n = e - RExC_parse; while (isSPACE(*(RExC_parse + n - 1))) n--; - } - else { + } /* The \p isn't immediately followed by a '{' */ + else if (! isALPHA(*RExC_parse)) { + RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1; + vFAIL2("Character following \\%c must be '{' or a " + "single-character Unicode property name", + (U8) value); + } + else { e = RExC_parse; n = 1; } if (!SIZE_ONLY) { SV* invlist; char* name; + char* base_name; /* name after any packages are stripped */ + const char * const colon_colon = "::"; - if (UCHARAT(RExC_parse) == '^') { - RExC_parse++; - n--; - /* toggle. (The rhs xor gets the single bit that - * differs between P and p; the other xor inverts just - * that bit) */ - value ^= 'P' ^ 'p'; - - while (isSPACE(*RExC_parse)) { - RExC_parse++; - n--; - } - } /* Try to get the definition of the property into * . If /i is in effect, the effective property * will have its name be <__NAME_i>. The design is @@ -14655,7 +14683,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, /* Look up the property name, and get its swash and * inversion list, if the property is found */ - if (swash) { + if (swash) { /* Return any left-overs */ SvREFCNT_dec_NN(swash); } swash = _core_swash_init("utf8", name, &PL_sv_undef, @@ -14668,26 +14696,57 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, HV* curpkg = (IN_PERL_COMPILETIME) ? PL_curstash : CopSTASH(PL_curcop); - if (swash) { + UV final_n = n; + bool has_pkg; + + if (swash) { /* Got a swash but no inversion list. + Something is likely wrong that will + be sorted-out later */ SvREFCNT_dec_NN(swash); swash = NULL; } - /* Here didn't find it. It could be a user-defined - * property that will be available at run-time. If we - * accept only compile-time properties, is an error; - * otherwise add it to the list for run-time look up */ - if (ret_invlist) { + /* Here didn't find it. It could be a an error (like a + * typo) in specifying a Unicode property, or it could + * be a user-defined property that will be available at + * run-time. The names of these must begin with 'In' + * or 'Is' (after any packages are stripped off). So + * if not one of those, or if we accept only + * compile-time properties, is an error; otherwise add + * it to the list for run-time look up. */ + if ((base_name = rninstr(name, name + n, + colon_colon, colon_colon + 2))) + { /* Has ::. We know this must be a user-defined + property */ + base_name += 2; + final_n -= base_name - name; + has_pkg = TRUE; + } + else { + base_name = name; + has_pkg = FALSE; + } + + if ( final_n < 3 + || base_name[0] != 'I' + || (base_name[1] != 's' && base_name[1] != 'n') + || ret_invlist) + { + const char * const msg + = (has_pkg) + ? "Illegal user-defined property name" + : "Can't find Unicode property definition"; RExC_parse = e + 1; - vFAIL2utf8f( - "Property '%"UTF8f"' is unknown", - UTF8fARG(UTF, n, name)); + + /* diag_listed_as: Can't find Unicode property definition "%s" */ + vFAIL3utf8f("%s \"%"UTF8f"\"", + msg, UTF8fARG(UTF, n, name)); } /* If the property name doesn't already have a package * name, add the current one to it so that it can be * referred to outside it. [perl #121777] */ - if (curpkg && ! instr(name, "::")) { + if (! has_pkg && curpkg) { char* pkgname = HvNAME(curpkg); if (strNE(pkgname, "main")) { char* full_name = Perl_form(aTHX_ @@ -14707,9 +14766,9 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, ANYOF node */ /* We don't know yet, so have to assume that the - * property could match something in the Latin1 range, - * hence something that isn't utf8. Note that this - * would cause things in to match + * property could match something in the upper Latin1 + * range, hence something that isn't utf8. Note that + * this would cause things in to match * inappropriately, except that any \p{}, including * this one forces Unicode semantics, which means there * is no */ @@ -15060,10 +15119,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, } } /* end of namedclass \blah */ - if (skip_white) { - RExC_parse = regpatws(pRExC_state, RExC_parse, - FALSE /* means don't recognize comments */ ); - } + SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse); /* If 'range' is set, 'value' is the ending of a range--check its * validity. (If value isn't a single code point in the case of a @@ -15104,12 +15160,9 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, && *RExC_parse == '-') { char* next_char_ptr = RExC_parse + 1; - if (skip_white) { /* Get the next real char after the '-' */ - next_char_ptr = regpatws(pRExC_state, - RExC_parse + 1, - FALSE); /* means don't recognize - comments */ - } + + /* Get the next real char after the '-' */ + SKIP_BRACKETED_WHITE_SPACE(skip_white, next_char_ptr); /* If the '-' is at the end of the class (just before the ']', * it is a literal minus; otherwise it is a range */ @@ -16088,7 +16141,11 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, RExC_parse = (char *)orig_parse; RExC_emit = (regnode *)orig_emit; - ret = reg_node(pRExC_state, op); + if (regarglen[op]) { + ret = reganode(pRExC_state, op, 0); + } else { + ret = reg_node(pRExC_state, op); + } RExC_parse = (char *)cur_parse; @@ -16397,50 +16454,86 @@ S_reg_skipcomment(RExC_state_t *pRExC_state, char* p) return p; } -/* nextchar() - - Advances the parse position, and optionally absorbs - "whitespace" from the inputstream. +STATIC void +S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state, + char ** p, + const bool force_to_xmod + ) +{ + /* If the text at the current parse position '*p' is a '(?#...)' comment, + * or if we are under /x or 'force_to_xmod' is TRUE, and the text at '*p' + * is /x whitespace, advance '*p' so that on exit it points to the first + * byte past all such white space and comments */ - Without /x "whitespace" means (?#...) style comments only, - with /x this means (?#...) and # comments and whitespace proper. + const bool use_xmod = force_to_xmod || (RExC_flags & RXf_PMf_EXTENDED); - Returns the RExC_parse point from BEFORE the scan occurs. + PERL_ARGS_ASSERT_SKIP_TO_BE_IGNORED_TEXT; - This is the /x friendly way of saying RExC_parse++. -*/ - -STATIC char* -S_nextchar(pTHX_ RExC_state_t *pRExC_state) -{ - char* const retval = RExC_parse++; - - PERL_ARGS_ASSERT_NEXTCHAR; + assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p)); for (;;) { - if (RExC_end - RExC_parse >= 3 - && *RExC_parse == '(' - && RExC_parse[1] == '?' - && RExC_parse[2] == '#') + if (RExC_end - (*p) >= 3 + && *(*p) == '(' + && *(*p + 1) == '?' + && *(*p + 2) == '#') { - while (*RExC_parse != ')') { - if (RExC_parse == RExC_end) + while (*(*p) != ')') { + if ((*p) == RExC_end) FAIL("Sequence (?#... not terminated"); - RExC_parse++; + (*p)++; } - RExC_parse++; + (*p)++; continue; } - if (RExC_flags & RXf_PMf_EXTENDED) { - char * p = regpatws(pRExC_state, RExC_parse, - TRUE); /* means recognize comments */ - if (p != RExC_parse) { - RExC_parse = p; + + if (use_xmod) { + const char * save_p = *p; + while ((*p) < RExC_end) { + STRLEN len; + if ((len = is_PATWS_safe((*p), RExC_end, UTF))) { + (*p) += len; + } + else if (*(*p) == '#') { + (*p) = reg_skipcomment(pRExC_state, (*p)); + } + else { + break; + } + } + if (*p != save_p) { continue; } } - return retval; + + break; } + + return; +} + +/* nextchar() + + Advances the parse position by one byte, unless that byte is the beginning + of a '(?#...)' style comment, or is /x whitespace and /x is in effect. In + those two cases, the parse position is advanced beyond all such comments and + white space. + + This is the UTF, (?#...), and /x friendly way of saying RExC_parse++. +*/ + +STATIC void +S_nextchar(pTHX_ RExC_state_t *pRExC_state) +{ + PERL_ARGS_ASSERT_NEXTCHAR; + + assert( ! UTF + || UTF8_IS_INVARIANT(*RExC_parse) + || UTF8_IS_START(*RExC_parse)); + + RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1; + + skip_to_be_ignored_text(pRExC_state, &RExC_parse, + FALSE /* Don't assume /x */ ); } STATIC regnode * @@ -17084,7 +17177,8 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ || k == GROUPP || OP(o)==ACCEPT) { AV *name_list= NULL; - Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */ + U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o); + Perl_sv_catpvf(aTHX_ sv, "%"UVuf, (UV)parno); /* Parenth number */ if ( RXp_PAREN_NAMES(prog) ) { name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]); } else if ( pRExC_state ) { @@ -17092,12 +17186,12 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } if (name_list) { if ( k != REF || (OP(o) < NREF)) { - SV **name= av_fetch(name_list, ARG(o), 0 ); + SV **name= av_fetch(name_list, parno, 0 ); if (name) Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name)); } else { - SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]); + SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]); I32 *nums=(I32*)SvPVX(sv_dat); SV **name= av_fetch(name_list, nums[0], 0 ); I32 n; @@ -17140,11 +17234,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name)); } } - else if (k == VERB) { - if (!o->flags) - Perl_sv_catpvf(aTHX_ sv, ":%"SVf, - SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ])))); - } else if (k == LOGICAL) + else if (k == LOGICAL) /* 2: embedded, otherwise 1 */ Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); else if (k == ANYOF) { @@ -17323,6 +17413,12 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags)); else if (OP(o) == SBOL) Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^"); + + /* add on the verb argument if there is one */ + if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) { + Perl_sv_catpvf(aTHX_ sv, ":%"SVf, + SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ])))); + } #else PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(sv); @@ -18114,9 +18210,13 @@ S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals) this_end = (end < NUM_ANYOF_CODE_POINTS) ? end : NUM_ANYOF_CODE_POINTS - 1; +#if NUM_ANYOF_CODE_POINTS > 256 format = (this_end < 256) ? "\\x{%02"UVXf"}-\\x{%02"UVXf"}" : "\\x{%04"UVXf"}-\\x{%04"UVXf"}"; +#else + format = "\\x{%02"UVXf"}-\\x{%02"UVXf"}"; +#endif GCC_DIAG_IGNORE(-Wformat-nonliteral); Perl_sv_catpvf(aTHX_ sv, format, start, this_end); GCC_DIAG_RESTORE; diff --git a/regcomp.sym b/regcomp.sym index 201c65e..8f9861a 100644 --- a/regcomp.sym +++ b/regcomp.sym @@ -199,9 +199,8 @@ DEFINEP DEFINEP, none 1 ; Never execute directly. #*Backtracking Verbs ENDLIKE ENDLIKE, none ; Used only for the type field of verbs -OPFAIL ENDLIKE, none ; Same as (?!) -ACCEPT ENDLIKE, parno 1 ; Accepts the current matched string. - +OPFAIL ENDLIKE, no-sv 1 ; Same as (?!), but with verb arg +ACCEPT ENDLIKE, no-sv/num 2L ; Accepts the current matched string, with verbar #*Verbs With Arguments VERB VERB, no-sv 1 ; Used only for the type field of verbs diff --git a/regen/op_private b/regen/op_private index 51e01b6..ab63e11 100644 --- a/regen/op_private +++ b/regen/op_private @@ -379,9 +379,6 @@ addbits($_, 7 => qw(OPpLVAL_INTRO LVINTRO)) addbits($_, 4 => qw(OPpTARGET_MY TARGMY)) for ops_with_flag('T'), - # This flag is also used to indicate matches against implicit $_, - # where $_ is lexical; e.g. my $_; ....; /foo/ - qw(match subst pushre qr trans transr); ; @@ -625,7 +622,7 @@ addbits('rv2gv', addbits('enteriter', 2 => qw(OPpITER_REVERSED REVERSED),# for (reverse ...) - 3 => qw(OPpITER_DEF DEF), # 'for $_' or 'for my $_' + 3 => qw(OPpITER_DEF DEF), # 'for $_' ); addbits('iter', 2 => qw(OPpITER_REVERSED REVERSED)); @@ -709,11 +706,6 @@ for (grep { $_ !~ /^l?stat$/ } ops_with_flag('-')) { -addbits($_, 1 => qw(OPpGREP_LEX GREPLEX)) # iterate over lexical $_ - for qw(mapwhile mapstart grepwhile grepstart); - - - addbits('entereval', 1 => qw(OPpEVAL_HAS_HH HAS_HH ), # Does it have a copy of %^H ? 2 => qw(OPpEVAL_UNICODE UNI ), diff --git a/regen/regcomp.pl b/regen/regcomp.pl index b90efc7..9890a1a 100644 --- a/regen/regcomp.pl +++ b/regen/regcomp.pl @@ -1,5 +1,6 @@ #!/usr/bin/perl -w -# +# +# # Regenerate (overwriting only if changed): # # pod/perldebguts.pod @@ -23,113 +24,204 @@ BEGIN { } use strict; -open DESC, 'regcomp.sym'; - -my $ind = 0; -my (@name,@rest,@type,@code,@args,@flags,@longj,@cmnt); -my ($longest_name_length,$desc,$lastregop) = 0; -my (%seen_op, %type_alias); -while () { - # Special pod comments - if (/^#\* ?/) { $cmnt[$ind] .= "# $'"; } - # Truly blank lines possibly surrounding pod comments - elsif (/^\s*$/) { $cmnt[$ind] .= "\n" } - - next if /^(?:#|\s*$)/; - chomp; # No \z in 5.004 - s/\s*$//; - if (/^-+\s*$/) { - $lastregop= $ind; - next; +# NOTE I don't think anyone actually knows what all of these properties mean, +# and I suspect some of them are outright unused. This is a first attempt to +# clean up the generation so maybe one day we can move to something more self +# documenting. (One might argue that an array of hashes of properties would +# be easier to use.) +# +# Why we use the term regnode and nodes, and not say, opcodes, I am not sure. + +# General thoughts: +# 1. We use a single continuum to represent both opcodes and states, +# and in regexec.c we switch on the combined set. +# 2. Opcodes have more information associated to them, states are simpler, +# basically just an identifier/number that can be used to switch within +# the state machine. +# 3. Some opcode are order dependent. +# 4. Output files often use "tricks" to reduce diff effects. Some of what +# we do below is more clumsy looking than it could be because of this. + +# Op/state properties: +# +# Property In Descr +# ---------------------------------------------------------------------------- +# name Both Name of op/state +# id Both integer value for this opcode/state +# optype Both Either 'op' or 'state' +# line_num Both line_num number of the input file for this item. +# type Op Type of node (aka regkind) +# code Op what code is associated with this node (???) +# args Op what type of args the node has (which regnode struct) +# flags Op (???) +# longj Op Whether this node is a longjump +# comment Both Comment about node, if any +# pod_comment Both Special comments for pod output (preceding lines in def) + +# Global State +my @all; # all opcodes/state +my %all; # hash of all opcode/state names + +my @ops; # array of just opcodes +my @states; # array of just states + +my $longest_name_length= 0; # track lengths of names for nicer reports +my (%type_alias); # map the type (??) + +# register a newly constructed node into our state tables. +# ensures that we have no name collisions (on name anyway), +# and issues the "id" for the node. +sub register_node { + my ($node)= @_; + + if ( $all{ $node->{name} } ) { + die "Duplicate item '$node->{name}' in regcomp.sym line $node->{line_num} " + . "previously defined on line $all{ $node->{name} }{line_num}\n"; + } elsif (!$node->{optype}) { + die "must have an optype in node ", Dumper($node); + } elsif ($node->{optype} eq "op") { + push @ops, $node; + } elsif ($node->{optype} eq "state") { + push @states, $node; + } else { + die "Uknown optype '$node->{optype}' in ", Dumper($node); } - unless ($lastregop) { - ($name[$ind], $desc, $rest[$ind]) = /^(\S+)\s+([^\t]+?)\s*;\s*(.*)/; + $node->{id}= 0 + @all; + push @all, $node; + $all{ $node->{name} }= $node; +} - if (defined $seen_op{$name[$ind]}) { - die "Duplicate regop $name[$ind] in regcomp.sym line $. previously defined on line $seen_op{$name[$ind]}\n"; - } else { - $seen_op{$name[$ind]}= $.; - } +# Parse and add an opcode definition to the global state. +# An opcode definition looks like this: +# +# +- args +# | +- flags +# | | +- longjmp +# Name Type code | | | ; comment +# -------------------------------------------------------------------------- +# IFMATCH BRANCHJ, off 1 . 2 ; Succeeds if the following matches. +# UNLESSM BRANCHJ, off 1 . 2 ; Fails if the following matches. +# SUSPEND BRANCHJ, off 1 V 1 ; "Independent" sub-RE. +# IFTHEN BRANCHJ, off 1 V 1 ; Switch, should be preceded by switcher. +# GROUPP GROUPP, num 1 ; Whether the group matched. +# +# Not every opcode definition has all of these. We should maybe make this +# nicer/easier to read in the future. Also note that the above is tab +# sensitive. + +sub parse_opcode_def { + my ( $text, $line_num, $pod_comment )= @_; + my $node= { + line_num => $line_num, + pod_comment => $pod_comment, + optype => "op", + }; - ($type[$ind], $code[$ind], $args[$ind], $flags[$ind], $longj[$ind]) - = split /[,\s]\s*/, $desc; + # first split the line into three, the initial NAME, a middle part + # that we call "desc" which contains various (not well documented) things, + # and a comment section. + @{$node}{qw(name desc comment)}= /^(\S+)\s+([^\t]+?)\s*;\s*(.*)/ + or die "Failed to match $_"; - if (!defined $seen_op{$type[$ind]} and !defined $type_alias{$type[$ind]}) { - #warn "Regop type '$type[$ind]' from regcomp.sym line $. is not an existing regop, and will be aliased to $name[$ind]\n" - # if -t STDERR; - $type_alias{$type[$ind]}= $name[$ind]; - } + # the content of the "desc" field from the first step is extracted here: + @{$node}{qw(type code args flags longj)}= split /[,\s]\s*/, $node->{desc}; - $longest_name_length = length $name[$ind] - if length $name[$ind] > $longest_name_length; - ++$ind; - } else { - my ($type,@lists)=split /\s+/, $_; - die "No list? $type" if !@lists; - foreach my $list (@lists) { - my ($names,$special)=split /:/, $list , 2; - $special ||= ""; - foreach my $name (split /,/,$names) { - my $real= $name eq 'resume' - ? "resume_$type" - : "${type}_$name"; - my @suffix; - if (!$special) { - @suffix=(""); - } elsif ($special=~/\d/) { - @suffix=(1..$special); - } elsif ($special eq 'FAIL') { - @suffix=("","_fail"); - } else { - die "unknown :type ':$special'"; - } - foreach my $suffix (@suffix) { - $name[$ind]="$real$suffix"; - $type[$ind]=$type; - $rest[$ind]="state for $type"; - ++$ind; - } + $node->{$_} //= "" for qw(type code args flags longj); + + register_node($node); # has to be before the type_alias code below + + if ( !$all{ $node->{type} } and !$type_alias{ $node->{type} } ) { + + #warn "Regop type '$node->{type}' from regcomp.sym line $line_num" + # ." is not an existing regop, and will be aliased to $node->{name}\n" + # if -t STDERR; + $type_alias{ $node->{type} }= $node->{name}; + } + + $longest_name_length= length $node->{name} + if length $node->{name} > $longest_name_length; +} + +# parse out a state definition and add the resulting data +# into the global state. may create multiple new states from +# a single definition (this is part of the point). +# Format for states: +# REGOP \t typelist [ \t typelist] +# typelist= namelist +# = namelist:FAIL +# = name:count +# Eg: +# WHILEM A_pre,A_min,A_max,B_min,B_max:FAIL +# BRANCH next:FAIL +# CURLYM A,B:FAIL +# +# The CURLYM definition would create the states: +# CURLYM_A, CURLYM_A_fail, CURLYM_B, CURLYM_B_fail +sub parse_state_def { + my ( $text, $line_num, $pod_comment )= @_; + my ( $type, @lists )= split /\s+/, $text; + die "No list? $type" if !@lists; + foreach my $list (@lists) { + my ( $names, $special )= split /:/, $list, 2; + $special ||= ""; + foreach my $name ( split /,/, $names ) { + my $real= + $name eq 'resume' + ? "resume_$type" + : "${type}_$name"; + my @suffix; + if ( !$special ) { + @suffix= (""); + } + elsif ( $special =~ /\d/ ) { + @suffix= ( 1 .. $special ); + } + elsif ( $special eq 'FAIL' ) { + @suffix= ( "", "_fail" ); + } + else { + die "unknown :type ':$special'"; + } + foreach my $suffix (@suffix) { + my $node= { + name => "$real$suffix", + optype => "state", + type => $type || "", + comment => "state for $type", + line_num => $line_num, + }; + register_node($node); } } - } } -# use fixed width to keep the diffs between regcomp.pl recompiles -# as small as possible. -my ($width,$rwidth,$twidth)=(22,12,9); -$lastregop ||= $ind; -my $tot = $ind; -close DESC; -die "Too many regexp/state opcodes! Maximum is 256, but there are $lastregop in file!" - if $lastregop>256; sub process_flags { - my ($flag, $varname, $comment) = @_; - $comment = '' unless defined $comment; - - $ind = 0; - my @selected; - my $bitmap = ''; - do { - my $set = $flags[$ind] && $flags[$ind] eq $flag ? 1 : 0; - # Whilst I could do this with vec, I'd prefer to do longhand the arithmetic - # ops in the C code. - my $current = do { - local $^W; - ord do { - substr $bitmap, ($ind >> 3); - } - }; - substr($bitmap, ($ind >> 3), 1) = chr($current | ($set << ($ind & 7))); - - push @selected, $name[$ind] if $set; - } while (++$ind < $lastregop); - my $out_string = join ', ', @selected, 0; - $out_string =~ s/(.{1,70},) /$1\n /g; + my ( $flag, $varname, $comment )= @_; + $comment= '' unless defined $comment; + + my @selected; + my $bitmap= ''; + for my $node (@ops) { + my $set= $node->{flags} && $node->{flags} eq $flag ? 1 : 0; + + # Whilst I could do this with vec, I'd prefer to do longhand the arithmetic + # ops in the C code. + my $current= do { + no warnings; + ord substr $bitmap, ( $node->{id} >> 3 ); + }; + substr( $bitmap, ( $node->{id} >> 3 ), 1 )= + chr( $current | ( $set << ( $node->{id} & 7 ) ) ); + + push @selected, $node->{name} if $set; + } + my $out_string= join ', ', @selected, 0; + $out_string =~ s/(.{1,70},) /$1\n /g; - my $out_mask = join ', ', map {sprintf "0x%02X", ord $_} split '', $bitmap; + my $out_mask= join ', ', map { sprintf "0x%02X", ord $_ } split '', $bitmap; - return $comment . <<"EOP"; + return $comment . <<"EOP"; #define REGNODE_\U$varname\E(node) (PL_${varname}_bitmask[(node) >> 3] & (1 << ((node) & 7))) #ifndef DOINIT @@ -150,36 +242,78 @@ EXTCONST U8 PL_${varname}_bitmask[] = { EOP } -my $out = open_new('regnodes.h', '>', - { by => 'regen/regcomp.pl', from => 'regcomp.sym' }); -printf $out <) { + + # Special pod comments + if (/^#\* ?/) { $pod_comment .= "# $'"; } + + # Truly blank lines possibly surrounding pod comments + elsif (/^\s*$/) { $pod_comment .= "\n" } + + next if /\A\s*#/ || /\A\s*\z/; + + s/\s*\z//; + if (/^-+\s*$/) { + $seen_sep= 1; + next; + } + + if ($seen_sep) { + parse_state_def( $_, $., $pod_comment ); + } + else { + parse_opcode_def( $_, $., $pod_comment ); + } + $pod_comment= ""; + } + close $in_fh; + die "Too many regexp/state opcodes! Maximum is 256, but there are ", 0 + @all, + " in file!" + if @all > 256; +} + +# use fixed width to keep the diffs between regcomp.pl recompiles +# as small as possible. +my ( $width, $rwidth, $twidth )= ( 22, 12, 9 ); + +sub print_state_defs { + my ($out)= @_; + printf $out < $lastregop - 1, - -$width, REGMATCH_STATE_MAX => $tot - 1 -; - -my %rev_type_alias= reverse %type_alias; -for ($ind=0; $ind < $lastregop ; ++$ind) { - printf $out "#define\t%*s\t%d\t/* %#04x %s */\n", - -$width, $name[$ind], $ind, $ind, $rest[$ind]; - if (defined(my $alias= $rev_type_alias{$name[$ind]})) { - printf $out "#define\t%*s\t%d\t/* %#04x %s */\n", - -$width, $alias, $ind, $ind, "type alias"; - } + -$width, + REGNODE_MAX => $#ops, + -$width, REGMATCH_STATE_MAX => $#all; + + my %rev_type_alias= reverse %type_alias; + for my $node (@ops) { + printf $out "#define\t%*s\t%d\t/* %#04x %s */\n", + -$width, $node->{name}, $node->{id}, $node->{id}, $node->{comment}; + if ( defined( my $alias= $rev_type_alias{ $node->{name} } ) ) { + printf $out "#define\t%*s\t%d\t/* %#04x %s */\n", + -$width, $alias, $node->{id}, $node->{id}, "type alias"; + } + } -} -print $out "\t/* ------------ States ------------- */\n"; -for ( ; $ind < $tot ; $ind++) { - printf $out "#define\t%*s\t(REGNODE_MAX + %d)\t/* %s */\n", - -$width, $name[$ind], $ind - $lastregop + 1, $rest[$ind]; + print $out "\t/* ------------ States ------------- */\n"; + for my $node (@states) { + printf $out "#define\t%*s\t(REGNODE_MAX + %d)\t/* %s */\n", + -$width, $node->{name}, $node->{id} - $#ops, $node->{comment}; + } } -print $out <{type} or !defined( $node->{name} ); + printf $out "\t%*s\t/* %*s */\n", + -1 - $twidth, "$node->{type},", -$width, $node->{name}; + print $out "\t/* ------------ States ------------- */\n" + if $node->{id} == $#ops and $node->{id} != $#all; + } -$ind = 0; -do { - printf $out "\t%*s\t/* %*s */\n", - -1-$twidth, "$type[$ind],", -$width, $name[$ind]; - print $out "\t/* ------------ States ------------- */\n" - if $ind + 1 == $lastregop and $lastregop != $tot; -} while (++$ind < $tot); - -print $out <($out) for @_; + print $out <{args}; -print $out <{name}; + } + + print $out <{longj} || 0; - printf $out "\t%d,\t/* %*s */\n", - $size, -$rwidth, $name[$ind] -} while (++$ind < $lastregop); + printf $out "\t%d,\t/* %*s */\n", $size, -$rwidth, $node->{name}; + } -print $out <{longj} || 0; + + printf $out "\t%*s\t/* $sym%#04x */\n", + -3 - $width, qq("$node->{name}",), $node->{id} - $ofs; + if ( $node->{id} == $#ops and @ops != @all ) { + print $out "\t/* ------------ States ------------- */\n"; + $ofs= $#ops; + $sym= 'REGNODE_MAX +'; + } + } -print $out <) { - - # optional leading '_'. Return symbol in $1, and strip it from - # rest of line - if (s/^ \# \s* define \s+ ( _? RXf_ \w+ ) \s+ //xi) { - chomp; - my $define = $1; - my $orig= $_; - s{ /\* .*? \*/ }{ }x; # Replace comments by a blank - - # Replace any prior defined symbols by their values - foreach my $key (keys %definitions) { - s/\b$key\b/$definitions{$key}/g; - } + my %rxfv; + my %definitions; # Remember what the symbol definitions are + my $val= 0; + my %reverse; + my $REG_EXTFLAGS_NAME_SIZE= 0; + foreach my $file ( "op_reg_common.h", "regexp.h" ) { + open my $in_fh, "<", $file or die "Can't read '$file': $!"; + while (<$in_fh>) { + + # optional leading '_'. Return symbol in $1, and strip it from + # comment of line + if (s/^ \# \s* define \s+ ( _? RXf_ \w+ ) \s+ //xi) { + chomp; + my $define= $1; + my $orig= $_; + s{ /\* .*? \*/ }{ }x; # Replace comments by a blank + + # Replace any prior defined symbols by their values + foreach my $key ( keys %definitions ) { + s/\b$key\b/$definitions{$key}/g; + } - # Remove the U suffix from unsigned int literals - s/\b([0-9]+)U\b/$1/g; + # Remove the U suffix from unsigned int literals + s/\b([0-9]+)U\b/$1/g; - my $newval = eval $_; # Get numeric definition + my $newval= eval $_; # Get numeric definition - $definitions{$define} = $newval; + $definitions{$define}= $newval; - next unless $_ =~ /<) { - # optional leading '_'. Return symbol in $1, and strip it from - # rest of line - if (m/^ \# \s* define \s+ ( PREGf_ ( \w+ ) ) \s+ 0x([0-9a-f]+)(?:\s*\/\*(.*)\*\/)?/xi) { - chomp; - my $define = $1; - my $abbr= $2; - my $hex= $3; - my $comment= $4; - my $val= hex($hex); - $comment= $comment ? " - $comment" : ""; - - printf $out qq(\t%-30s/* 0x%08x - %s%s */\n), qq("$abbr",), $val, $define, $comment; - $REG_INTFLAGS_NAME_SIZE++; + my %rxfv; + my %definitions; # Remember what the symbol definitions are + my $val= 0; + my %reverse; + my $REG_INTFLAGS_NAME_SIZE= 0; + foreach my $file ("regcomp.h") { + open my $fh, "<", $file or die "Can't read $file: $!"; + while (<$fh>) { + + # optional leading '_'. Return symbol in $1, and strip it from + # comment of line + if ( + m/^ \# \s* define \s+ ( PREGf_ ( \w+ ) ) \s+ 0x([0-9a-f]+)(?:\s*\/\*(.*)\*\/)?/xi + ) + { + chomp; + my $define= $1; + my $abbr= $2; + my $hex= $3; + my $comment= $4; + my $val= hex($hex); + $comment= $comment ? " - $comment" : ""; + + printf $out qq(\t%-30s/* 0x%08x - %s%s */\n), qq("$abbr",), + $val, $define, $comment; + $REG_INTFLAGS_NAME_SIZE++; + } } } -} -print $out <'); +sub do_perldebguts { + my $guts= open_new( 'pod/perldebguts.pod', '>' ); -my $code; -my $name_fmt = '<' x ($longest_name_length-1); -my $descr_fmt = '<' x (58-$longest_name_length); -eval <{pod_comment} ^$name_fmt ^<<<<<<<<< ^$descr_fmt~~ - \$name[\$_], \$code, \$rest[\$_] + \$node->{name}, \$code, \$node->{comment}//'' . +1; EOD - -select +(select($guts), do { - $~ = "GuTS"; + + my $old_fh= select($guts); + $~= "GuTS"; open my $oldguts, "pod/perldebguts.pod" or die "$0 cannot open pod/perldebguts.pod for reading: $!"; - while(<$oldguts>) { + while (<$oldguts>) { print; last if /=for regcomp.pl begin/; } - print <<'end'; + print <<'END_OF_DESCR'; # TYPE arg-description [num-args] [longjump-len] DESCRIPTION -end - for (0..$lastregop-1) { - $code = "$code[$_] ".($args[$_]||""); - $code .= " $longj[$_]" if $longj[$_]; - if ($cmnt[$_] ||= "") { +END_OF_DESCR + for my $n (@ops) { + $node= $n; + $code= "$node->{code} " . ( $node->{args} || "" ); + $code .= " $node->{longj}" if $node->{longj}; + if ( $node->{pod_comment} ||= "" ) { + # Trim multiple blanks - $cmnt[$_] =~ s/^\n\n+/\n/; $cmnt[$_] =~ s/\n\n+$/\n\n/ + $node->{pod_comment} =~ s/^\n\n+/\n/; + $node->{pod_comment} =~ s/\n\n+$/\n\n/; } write; } print "\n"; - while(<$oldguts>) { + while (<$oldguts>) { last if /=for regcomp.pl end/; } do { print } while <$oldguts>; + select $old_fh; + close_and_rename($guts); +} -})[0]; +read_definition("regcomp.sym"); +my $out= open_new( 'regnodes.h', '>', + { by => 'regen/regcomp.pl', from => 'regcomp.sym' } ); +print_state_defs($out); +print_regkind($out); +wrap_ifdef_print( + $out, + "REG_COMP_C", + \&print_regarglen, + \&print_reg_off_by_arg +); +print_reg_name($out); +print_reg_extflags_name($out); +print_reg_intflags_name($out); +print_process_flags($out); +read_only_bottom_close_and_rename($out); -close_and_rename($guts); +do_perldebguts(); diff --git a/regen/warnings.pl b/regen/warnings.pl index c4cc19c..18f337e 100644 --- a/regen/warnings.pl +++ b/regen/warnings.pl @@ -16,7 +16,7 @@ # # This script is normally invoked from regen.pl. -$VERSION = '1.03'; +$VERSION = '1.35'; BEGIN { require 'regen/regen_lib.pl'; @@ -89,8 +89,6 @@ my $tree = { [ 5.017, DEFAULT_ON ], 'experimental::regex_sets' => [ 5.017, DEFAULT_ON ], - 'experimental::lexical_topic' => - [ 5.017, DEFAULT_ON ], 'experimental::smartmatch' => [ 5.017, DEFAULT_ON ], 'experimental::postderef' => @@ -416,6 +414,13 @@ EOM } while () { + last if /^VERSION$/ ; + print $pm $_ ; +} + +print $pm qq(our \$VERSION = "$::VERSION";\n); + +while () { last if /^KEYWORDS$/ ; print $pm $_ ; } @@ -481,7 +486,7 @@ read_only_bottom_close_and_rename($pm); __END__ package warnings; -our $VERSION = '1.33'; +VERSION # Verify that we're called correctly so that warnings will work. # see also strict.pm. @@ -1139,8 +1144,10 @@ this snippet of code: package MyMod::Abc; sub open { - warnings::warnif("deprecated", - "open is deprecated, use new instead"); + if (warnings::enabled("deprecated")) { + warnings::warn("deprecated", + "open is deprecated, use new instead"); + } new(@_); } diff --git a/regexec.c b/regexec.c index e92e7a3..85c31a6 100644 --- a/regexec.c +++ b/regexec.c @@ -1205,10 +1205,10 @@ Perl_re_intuit_start(pTHX_ * didn't contradict, so just retry the anchored "other" * substr */ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - " Found /%s^%s/m, rescanning for anchored from offset %ld (rx_origin now %"IVdf")...\n", + " Found /%s^%s/m, rescanning for anchored from offset %"IVdf" (rx_origin now %"IVdf")...\n", PL_colors[0], PL_colors[1], - (long)(rx_origin - strbeg + prog->anchored_offset), - (long)(rx_origin - strbeg) + (IV)(rx_origin - strbeg + prog->anchored_offset), + (IV)(rx_origin - strbeg) )); goto do_other_substr; } @@ -2065,14 +2065,17 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, FBC_BOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8); break; case GCB_BOUND: - if (s == reginfo->strbeg) { /* GCB always matches at begin and - end */ - if (to_complement ^ cBOOL(reginfo->intuit - || regtry(reginfo, &s))) + if (s == reginfo->strbeg) { + if (reginfo->intuit || regtry(reginfo, &s)) { goto got_it; } + + /* Didn't match. Try at the next position (if there is one) */ s += (utf8_target) ? UTF8SKIP(s) : 1; + if (UNLIKELY(s >= reginfo->strend)) { + break; + } } if (utf8_target) { @@ -2083,44 +2086,44 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, while (s < strend) { GCB_enum after = getGCB_VAL_UTF8((U8*) s, (U8*) reginfo->strend); - if (to_complement ^ isGCB(before, after)) { - if (reginfo->intuit || regtry(reginfo, &s)) { - goto got_it; - } - before = after; + if ( (to_complement ^ isGCB(before, after)) + && (reginfo->intuit || regtry(reginfo, &s))) + { + goto got_it; } + before = after; s += UTF8SKIP(s); } } else { /* Not utf8. Everything is a GCB except between CR and LF */ while (s < strend) { - if (to_complement ^ (UCHARAT(s - 1) != '\r' - || UCHARAT(s) != '\n')) + if ((to_complement ^ ( UCHARAT(s - 1) != '\r' + || UCHARAT(s) != '\n')) + && (reginfo->intuit || regtry(reginfo, &s))) { - if (reginfo->intuit || regtry(reginfo, &s)) { - goto got_it; - } - s++; + goto got_it; } + s++; } } - if (to_complement ^ cBOOL(reginfo->intuit || regtry(reginfo, &s))) { + /* And, since this is a bound, it can match after the final + * character in the string */ + if ((reginfo->intuit || regtry(reginfo, &s))) { goto got_it; } break; case SB_BOUND: - if (s == reginfo->strbeg) { /* SB always matches at beginning */ - if (to_complement - ^ cBOOL(reginfo->intuit || regtry(reginfo, &s))) - { + if (s == reginfo->strbeg) { + if (reginfo->intuit || regtry(reginfo, &s)) { goto got_it; } - - /* Didn't match. Go try at the next position */ s += (utf8_target) ? UTF8SKIP(s) : 1; + if (UNLIKELY(s >= reginfo->strend)) { + break; + } } if (utf8_target) { @@ -2131,18 +2134,17 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, while (s < strend) { SB_enum after = getSB_VAL_UTF8((U8*) s, (U8*) reginfo->strend); - if (to_complement ^ isSB(before, - after, - (U8*) reginfo->strbeg, - (U8*) s, - (U8*) reginfo->strend, - utf8_target)) + if ((to_complement ^ isSB(before, + after, + (U8*) reginfo->strbeg, + (U8*) s, + (U8*) reginfo->strend, + utf8_target)) + && (reginfo->intuit || regtry(reginfo, &s))) { - if (reginfo->intuit || regtry(reginfo, &s)) { - goto got_it; - } - before = after; + goto got_it; } + before = after; s += UTF8SKIP(s); } } @@ -2150,18 +2152,17 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, SB_enum before = getSB_VAL_CP((U8) *(s -1)); while (s < strend) { SB_enum after = getSB_VAL_CP((U8) *s); - if (to_complement ^ isSB(before, - after, - (U8*) reginfo->strbeg, - (U8*) s, - (U8*) reginfo->strend, - utf8_target)) + if ((to_complement ^ isSB(before, + after, + (U8*) reginfo->strbeg, + (U8*) s, + (U8*) reginfo->strend, + utf8_target)) + && (reginfo->intuit || regtry(reginfo, &s))) { - if (reginfo->intuit || regtry(reginfo, &s)) { - goto got_it; - } - before = after; + goto got_it; } + before = after; s++; } } @@ -2169,9 +2170,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, /* Here are at the final position in the target string. The SB * value is always true here, so matches, depending on other * constraints */ - if (to_complement ^ cBOOL(reginfo->intuit - || regtry(reginfo, &s))) - { + if (reginfo->intuit || regtry(reginfo, &s)) { goto got_it; } @@ -2179,12 +2178,13 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, case WB_BOUND: if (s == reginfo->strbeg) { - if (to_complement ^ cBOOL(reginfo->intuit - || regtry(reginfo, &s))) - { + if (reginfo->intuit || regtry(reginfo, &s)) { goto got_it; } s += (utf8_target) ? UTF8SKIP(s) : 1; + if (UNLIKELY(s >= reginfo->strend)) { + break; + } } if (utf8_target) { @@ -2202,20 +2202,19 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, while (s < strend) { WB_enum after = getWB_VAL_UTF8((U8*) s, (U8*) reginfo->strend); - if (to_complement ^ isWB(previous, - before, - after, - (U8*) reginfo->strbeg, - (U8*) s, - (U8*) reginfo->strend, - utf8_target)) + if ((to_complement ^ isWB(previous, + before, + after, + (U8*) reginfo->strbeg, + (U8*) s, + (U8*) reginfo->strend, + utf8_target)) + && (reginfo->intuit || regtry(reginfo, &s))) { - if (reginfo->intuit || regtry(reginfo, &s)) { - goto got_it; - } - previous = before; - before = after; + goto got_it; } + previous = before; + before = after; s += UTF8SKIP(s); } } @@ -2224,31 +2223,26 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, WB_enum before = getWB_VAL_CP((U8) *(s -1)); while (s < strend) { WB_enum after = getWB_VAL_CP((U8) *s); - if (to_complement ^ isWB(previous, - before, - after, - (U8*) reginfo->strbeg, - (U8*) s, - (U8*) reginfo->strend, - utf8_target)) + if ((to_complement ^ isWB(previous, + before, + after, + (U8*) reginfo->strbeg, + (U8*) s, + (U8*) reginfo->strend, + utf8_target)) + && (reginfo->intuit || regtry(reginfo, &s))) { - if (reginfo->intuit || regtry(reginfo, &s)) { - goto got_it; - } - previous = before; - before = after; + goto got_it; } + previous = before; + before = after; s++; } } - if (to_complement ^ cBOOL(reginfo->intuit - || regtry(reginfo, &s))) - { + if (reginfo->intuit || regtry(reginfo, &s)) { goto got_it; } - - break; } break; @@ -3478,7 +3472,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, /* - regtry - try match at specific point */ -STATIC I32 /* 0 failure, 1 success */ +STATIC bool /* 0 failure, 1 success */ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) { CHECKPOINT lastcp; @@ -4743,10 +4737,24 @@ S_backup_one_WB(pTHX_ WB_enum * previous, const U8 * const strbeg, U8 ** curpos, * to look it up */ if (*previous != WB_UNKNOWN) { wb = *previous; - *previous = WB_UNKNOWN; - /* XXX Note that doesn't change curpos, and maybe should */ - /* But we always back up over these two types */ + /* But we need to move backwards by one */ + if (utf8_target) { + *curpos = reghopmaybe3(*curpos, -1, strbeg); + if (! *curpos) { + *previous = WB_EDGE; + *curpos = (U8 *) strbeg; + } + else { + *previous = WB_UNKNOWN; + } + } + else { + (*curpos)--; + *previous = (*curpos <= strbeg) ? WB_EDGE : WB_UNKNOWN; + } + + /* And we always back up over these two types */ if (wb != WB_Extend && wb != WB_Format) { return wb; } @@ -5526,6 +5534,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) /* FALLTHROUGH */ case BOUNDL: /* /\b/l */ + { + bool b1, b2; _CHECK_AND_WARN_PROBLEMATIC_LOCALE; if (FLAGS(scan) != TRADITIONAL_BOUND) { @@ -5538,27 +5548,28 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) if (utf8_target) { if (locinput == reginfo->strbeg) - ln = isWORDCHAR_LC('\n'); + b1 = isWORDCHAR_LC('\n'); else { - ln = isWORDCHAR_LC_utf8(reghop3((U8*)locinput, -1, + b1 = isWORDCHAR_LC_utf8(reghop3((U8*)locinput, -1, (U8*)(reginfo->strbeg))); } - n = (NEXTCHR_IS_EOS) + b2 = (NEXTCHR_IS_EOS) ? isWORDCHAR_LC('\n') : isWORDCHAR_LC_utf8((U8*)locinput); } else { /* Here the string isn't utf8 */ - ln = (locinput == reginfo->strbeg) + b1 = (locinput == reginfo->strbeg) ? isWORDCHAR_LC('\n') : isWORDCHAR_LC(UCHARAT(locinput - 1)); - n = (NEXTCHR_IS_EOS) + b2 = (NEXTCHR_IS_EOS) ? isWORDCHAR_LC('\n') : isWORDCHAR_LC(nextchr); } - if (to_complement ^ (ln == n)) { + if (to_complement ^ (b1 == b2)) { sayNO; } break; + } case NBOUND: /* /\B/ */ to_complement = 1; @@ -5575,6 +5586,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) /* FALLTHROUGH */ case BOUNDA: /* /\b/a */ + { + bool b1, b2; bound_ascii_match_only: /* Here the string isn't utf8, or is utf8 and only ascii characters @@ -5586,16 +5599,17 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * 2) it is a multi-byte character, in which case the final byte is * never mistakable for ASCII, and so the test will say it is * not a word character, which is the correct answer. */ - ln = (locinput == reginfo->strbeg) + b1 = (locinput == reginfo->strbeg) ? isWORDCHAR_A('\n') : isWORDCHAR_A(UCHARAT(locinput - 1)); - n = (NEXTCHR_IS_EOS) + b2 = (NEXTCHR_IS_EOS) ? isWORDCHAR_A('\n') : isWORDCHAR_A(nextchr); - if (to_complement ^ (ln == n)) { + if (to_complement ^ (b1 == b2)) { sayNO; } break; + } case NBOUNDU: /* /\B/u */ to_complement = 1; @@ -5604,20 +5618,25 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) case BOUNDU: /* /\b/u */ boundu: - if (utf8_target) { - + if (UNLIKELY(reginfo->strbeg >= reginfo->strend)) { + match = FALSE; + } + else if (utf8_target) { bound_utf8: switch((bound_type) FLAGS(scan)) { case TRADITIONAL_BOUND: - ln = (locinput == reginfo->strbeg) + { + bool b1, b2; + b1 = (locinput == reginfo->strbeg) ? 0 /* isWORDCHAR_L1('\n') */ : isWORDCHAR_utf8(reghop3((U8*)locinput, -1, (U8*)(reginfo->strbeg))); - n = (NEXTCHR_IS_EOS) + b2 = (NEXTCHR_IS_EOS) ? 0 /* isWORDCHAR_L1('\n') */ : isWORDCHAR_utf8((U8*)locinput); - match = cBOOL(ln != n); + match = cBOOL(b1 != b2); break; + } case GCB_BOUND: if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) { match = TRUE; /* GCB always matches at begin and @@ -5679,14 +5698,17 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) else { /* Not utf8 target */ switch((bound_type) FLAGS(scan)) { case TRADITIONAL_BOUND: - ln = (locinput == reginfo->strbeg) + { + bool b1, b2; + b1 = (locinput == reginfo->strbeg) ? 0 /* isWORDCHAR_L1('\n') */ : isWORDCHAR_L1(UCHARAT(locinput - 1)); - n = (NEXTCHR_IS_EOS) + b2 = (NEXTCHR_IS_EOS) ? 0 /* isWORDCHAR_L1('\n') */ : isWORDCHAR_L1(nextchr); - match = cBOOL(ln != n); + match = cBOOL(b1 != b2); break; + } case GCB_BOUND: if (locinput == reginfo->strbeg || NEXTCHR_IS_EOS) { @@ -6529,7 +6551,9 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) break; case ACCEPT: /* (*ACCEPT) */ - if (ARG(scan)){ + if (scan->flags) + sv_yes_mark = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]); + if (ARG2L(scan)){ regnode *cursor; for (cursor=scan; cursor && OP(cursor)!=END; @@ -7001,8 +7025,9 @@ NULL NOT_REACHED; /* NOTREACHED */ case CUTGROUP: /* /(*THEN)/ */ - sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL : - MUTABLE_SV(rexi->data->data[ ARG( scan ) ]); + sv_yes_mark = st->u.mark.mark_name = scan->flags + ? MUTABLE_SV(rexi->data->data[ ARG( scan ) ]) + : NULL; PUSH_STATE_GOTO(CUTGROUP_next, next, locinput); /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ @@ -7699,7 +7724,7 @@ NULL /* FALLTHROUGH */ case PRUNE: /* (*PRUNE) */ - if (!scan->flags) + if (scan->flags) sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]); PUSH_STATE_GOTO(COMMIT_next, next, locinput); /* NOTREACHED */ @@ -7708,9 +7733,21 @@ NULL case COMMIT_next_fail: no_final = 1; /* FALLTHROUGH */ + sayNO; + NOT_REACHED; /* NOTREACHED */ case OPFAIL: /* (*FAIL) */ - sayNO; + if (scan->flags) + sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]); + if (logical) { + /* deal with (?(?!)X|Y) properly, + * make sure we trigger the no branch + * of the trailing IFTHEN structure*/ + sw= 0; + break; + } else { + sayNO; + } /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ @@ -7754,7 +7791,7 @@ NULL NOT_REACHED; /* NOTREACHED */ case SKIP: /* (*SKIP) */ - if (scan->flags) { + if (!scan->flags) { /* (*SKIP) : if we fail we cut here*/ ST.mark_name = NULL; ST.mark_loc = locinput; diff --git a/regnodes.h b/regnodes.h index cc3da9d..f27abe0 100644 --- a/regnodes.h +++ b/regnodes.h @@ -93,8 +93,8 @@ #define INSUBP 79 /* 0x4f Whether we are in a specific recurse. */ #define DEFINEP 80 /* 0x50 Never execute directly. */ #define ENDLIKE 81 /* 0x51 Used only for the type field of verbs */ -#define OPFAIL 82 /* 0x52 Same as (?!) */ -#define ACCEPT 83 /* 0x53 Accepts the current matched string. */ +#define OPFAIL 82 /* 0x52 Same as (?!), but with verb arg */ +#define ACCEPT 83 /* 0x53 Accepts the current matched string, with verbar */ #define VERB 84 /* 0x54 Used only for the type field of verbs */ #define PRUNE 85 /* 0x55 Pattern fails at this startpoint if no-backtracking through this */ #define MARKPOINT 86 /* 0x56 Push the current location for rollback by cut. */ @@ -291,9 +291,10 @@ EXTCONST U8 PL_regkind[] = { }; #endif +#ifdef REG_COMP_C + /* regarglen[] - How large is the argument part of the node (in regnodes) */ -#ifdef REG_COMP_C static const U8 regarglen[] = { 0, /* END */ 0, /* SUCCEED */ @@ -377,8 +378,8 @@ static const U8 regarglen[] = { EXTRA_SIZE(struct regnode_1), /* INSUBP */ EXTRA_SIZE(struct regnode_1), /* DEFINEP */ 0, /* ENDLIKE */ - 0, /* OPFAIL */ - EXTRA_SIZE(struct regnode_1), /* ACCEPT */ + EXTRA_SIZE(struct regnode_1), /* OPFAIL */ + EXTRA_SIZE(struct regnode_2L), /* ACCEPT */ EXTRA_SIZE(struct regnode_1), /* VERB */ EXTRA_SIZE(struct regnode_1), /* PRUNE */ EXTRA_SIZE(struct regnode_1), /* MARKPOINT */ @@ -492,6 +493,7 @@ static const char reg_off_by_arg[] = { #endif /* REG_COMP_C */ + /* reg_name[] - Opcode/state names in string form, for debugging */ #ifndef DOINIT diff --git a/scope.c b/scope.c index 9768c30..1b89186 100644 --- a/scope.c +++ b/scope.c @@ -31,6 +31,10 @@ Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n) { PERL_ARGS_ASSERT_STACK_GROW; + if (n < 0) + Perl_croak(aTHX_ + "panic: stack_grow() negative count (%"IVdf")", (IV)n); + PL_stack_sp = sp; #ifndef STRESS_REALLOC av_extend(PL_curstack, (p - PL_stack_base) + (n) + 128); diff --git a/sv.c b/sv.c index dc2ba8b..f0c1553 100644 --- a/sv.c +++ b/sv.c @@ -1525,7 +1525,11 @@ wrapper instead. =cut */ -int +/* prior to 5.000 stable, this function returned the new OOK-less SvFLAGS + prior to 5.23.4 this function always returned 0 +*/ + +void Perl_sv_backoff(SV *const sv) { STRLEN delta; @@ -1541,9 +1545,9 @@ Perl_sv_backoff(SV *const sv) SvLEN_set(sv, SvLEN(sv) + delta); SvPV_set(sv, SvPVX(sv) - delta); - Move(s, SvPVX(sv), SvCUR(sv)+1, char); SvFLAGS(sv) &= ~SVf_OOK; - return 0; + Move(s, SvPVX(sv), SvCUR(sv)+1, char); + return; } /* @@ -11444,9 +11448,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p is safe. */ is_utf8 = (bool)va_arg(*args, int); elen = va_arg(*args, UV); - if ((IV)elen < 0) { - /* check if utf8 length is larger than 0 when cast to IV */ - assert( (IV)elen >= 0 ); /* in DEBUGGING build we want to crash */ + /* if utf8 length is larger than 0x7ffff..., then it might + * have been a signed value that wrapped */ + if (elen > ((~(STRLEN)0) >> 1)) { + assert(0); /* in DEBUGGING build we want to crash */ elen= 0; /* otherwise we want to treat this as an empty string */ } eptr = va_arg(*args, char *); @@ -12690,7 +12695,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } - assert((IV)elen >= 0); /* here zero elen is fine */ + /* signed value that's wrapped? */ + assert(elen <= ((~(STRLEN)0) >> 1)); have = esignlen + zeros + elen; if (have < zeros) croak_memory_wrap(); diff --git a/sv.h b/sv.h index 331b823..e1797de 100644 --- a/sv.h +++ b/sv.h @@ -467,7 +467,7 @@ perform the upgrade if necessary. See C>. /* PVHV */ #define SVphv_HASKFLAGS 0x80000000 /* keys have flag byte after hash */ /* PVGV when SVpbm_VALID is true */ -#define SVpbm_TAIL 0x80000000 +#define SVpbm_TAIL 0x80000000 /* string has a fake "\n" appended */ /* RV upwards. However, SVf_ROK and SVp_IOK are exclusive */ #define SVprv_WEAKREF 0x80000000 /* Weak reference */ /* pad name vars only */ @@ -949,7 +949,7 @@ in gv.h: */ #define SvOOK(sv) (SvFLAGS(sv) & SVf_OOK) #define SvOOK_on(sv) (SvFLAGS(sv) |= SVf_OOK) -#define SvOOK_off(sv) ((void)(SvOOK(sv) && sv_backoff(sv))) +#define SvOOK_off(sv) ((void)(SvOOK(sv) && (sv_backoff(sv),0))) #define SvFAKE(sv) (SvFLAGS(sv) & SVf_FAKE) #define SvFAKE_on(sv) (SvFLAGS(sv) |= SVf_FAKE) @@ -1051,7 +1051,7 @@ For example, if your scalar is a reference and you want to modify the C slot, you can't just do C, as that will leak the referent. This is used internally by various sv-modifying functions, such as -C, C and C, C and C. One case that this does not handle is a gv without SvFAKE set. After diff --git a/symbian/config.sh b/symbian/config.sh index a5aa477..f1cf6ad 100644 --- a/symbian/config.sh +++ b/symbian/config.sh @@ -166,11 +166,8 @@ d_fpclassl='undef' d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' -d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='define' -d_fstatfs='undef' -d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='undef' @@ -181,7 +178,6 @@ d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' d_getespwnam='undef' -d_getfsstat='undef' d_getgrent='undef' d_getgrent_r='undef' d_getgrgid_r='undef' @@ -198,8 +194,6 @@ d_gethostprotos='define' d_getitimer='undef' d_getlogin='undef' d_getlogin_r='undef' -d_getmnt='undef' -d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' @@ -241,7 +235,6 @@ d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' -d_hasmntopt='undef' d_htonl='define' d_hypot='undef' d_ilogb='undef' @@ -469,10 +462,7 @@ d_sresgproto='undef' d_sresuproto='undef' d_stat='define' d_statblks='undef' -d_statfs_f_flags='undef' -d_statfs_s='undef' d_static_inline='undef' -d_statvfs='undef' d_stdio_cnt_lval='undef' d_stdio_ptr_lval='undef' d_stdio_ptr_lval_nochange_cnt='undef' @@ -531,7 +521,6 @@ d_unordered='undef' d_unsetenv='undef' d_usleep='define' d_usleepproto='undef' -d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' @@ -651,7 +640,6 @@ i_malloc='undef' i_mallocmalloc='undef' i_math='define' i_memory='undef' -i_mntent='undef' i_ndbm='undef' i_netdb='define' i_neterrno='undef' @@ -682,7 +670,6 @@ i_sysioctl='define' i_syslog='undef' i_sysmman='undef' i_sysmode='undef' -i_sysmount='undef' i_sysndir='undef' i_sysparam='undef' i_syspoll='undef' @@ -691,8 +678,6 @@ i_syssecrt='undef' i_sysselct='undef' i_syssockio='undef' i_sysstat='define' -i_sysstatfs='undef' -i_sysstatvfs='undef' i_systime='define' i_systimek='undef' i_systimes='define' @@ -700,13 +685,11 @@ i_systypes='define' i_sysuio='undef' i_sysun='undef' i_sysutsname='undef' -i_sysvfs='undef' i_syswait='undef' i_termio='undef' i_termios='undef' i_time='define' i_unistd='define' -i_ustat='undef' i_utime='undef' i_values='undef' i_varargs='undef' diff --git a/t/comp/uproto.t b/t/comp/uproto.t index f81e314..9db6d54 100644 --- a/t/comp/uproto.t +++ b/t/comp/uproto.t @@ -1,6 +1,6 @@ #!perl -print "1..43\n"; +print "1..32\n"; my $test = 0; sub failed { @@ -71,25 +71,6 @@ like( $@, qr/Not enough arguments for main::f at/ ); eval q{ f(1,2,3,4) }; like( $@, qr/Too many arguments for main::f at/ ); -{ - # We have not tested require/use/no yet, so we must avoid this: - # no warnings 'deprecated'; - BEGIN { $SIG{__WARN__} = sub {} } - my $_ = "quarante-deux"; - BEGIN { $SIG{__WARN__} = undef } - $foo = "FOO"; - $bar = "BAR"; - f("FOO quarante-deux", $foo); - f("BAR quarante-deux", $bar); - f("y quarante-deux", substr("xy",1,1)); - f("1 quarante-deux", ("abcdef" =~ /abc/)); - f("not undef quarante-deux", $undef || "not undef"); - f(" quarante-deux", -f "no_such_file"); - f("FOOBAR quarante-deux", ($foo . $bar)); - f("FOOBAR quarante-deux", ($foo .= $bar)); - f("FOOBAR quarante-deux", $foo); -} - &f(""); # no error sub g(_) { is(shift, $expected) } @@ -101,9 +82,6 @@ $_ = $expected; g(); g; undef $expected; &g; # $_ not passed -BEGIN { $SIG{__WARN__} = sub {} } -{ $expected = my $_ = "bar"; g() } -BEGIN { $SIG{__WARN__} = undef } eval q{ sub wrong1 (_$); wrong1(1,2) }; like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' ); @@ -147,10 +125,3 @@ sub double(_) { $_[0] *= 2 } $_ = 21; double(); is( $_, 42, '$_ is modifiable' ); -{ - BEGIN { $SIG{__WARN__} = sub {} } - my $_ = 22; - BEGIN { $SIG{__WARN__} = undef } - double(); - is( $_, 44, 'my $_ is modifiable' ); -} diff --git a/t/io/errno.t b/t/io/errno.t index 8d0f4b2..d8fc4b2 100644 --- a/t/io/errno.t +++ b/t/io/errno.t @@ -28,8 +28,10 @@ for my $perlio ('perlio', 'stdio') { SKIP: for my $test_in ("test\n", "test") { skip("Guaranteed newline at EOF on VMS", 4) if $^O eq 'VMS' && $test_in eq 'test'; - skip("[perl #71504] OpenBSD test failures in errno.t with ithreads and perlio", 8) - if $^O eq 'openbsd' && $Config{useithreads} && $perlio eq 'stdio'; + # perl #71504 added skip in openbsd+threads+stdio; + # then commit 23705063 made -lpthread the default. + skip("[perl #71504] OpenBSD test failures in errno.t with ithreads and perlio]; [perl #126306: openbsd t/io/errno.t tests fail randomly]", 8) + if $^O eq 'openbsd' && $perlio eq 'stdio'; my $test_in_esc = $test_in; $test_in_esc =~ s/\n/\\n/g; for my $rs_code ('', '$/=undef', '$/=\2', '$/=\1024') { diff --git a/t/lib/warnings/9uninit b/t/lib/warnings/9uninit index d26d6ca..ef9b4f6 100644 --- a/t/lib/warnings/9uninit +++ b/t/lib/warnings/9uninit @@ -786,17 +786,6 @@ s/$m1/$g1/; undef $_; tr/x/y/; undef $_; tr/x/y/r; undef $_; -my $_; -/y/; -/$m1/; -/$g1/; -s/y/z/; undef $_; -s/$m1/z/; undef $_; -s//$g1/; undef $_; -s/$m1/$g1/; undef $_; -tr/x/y/; undef $_; -tr/x/y/r; undef $_; - $g2 =~ /y/; $g2 =~ /$m1/; $g2 =~ /$g1/; @@ -822,7 +811,6 @@ undef $m1; $m1 =~ tr/x/y/; undef $m1; $m1 =~ tr/x/y/r; EXPECT -Use of my $_ is experimental at - line 16. Use of uninitialized value $_ in pattern match (m//) at - line 5. Use of uninitialized value $m1 in regexp compilation at - line 6. Use of uninitialized value $_ in pattern match (m//) at - line 6. @@ -841,52 +829,34 @@ Use of uninitialized value $_ in substitution (s///) at - line 12. Use of uninitialized value $g1 in substitution iterator at - line 12. Use of uninitialized value $_ in transliteration (tr///) at - line 13. Use of uninitialized value $_ in transliteration (tr///) at - line 14. -Use of uninitialized value $_ in pattern match (m//) at - line 17. -Use of uninitialized value $m1 in regexp compilation at - line 18. -Use of uninitialized value $_ in pattern match (m//) at - line 18. -Use of uninitialized value $g1 in regexp compilation at - line 19. -Use of uninitialized value $_ in pattern match (m//) at - line 19. -Use of uninitialized value $_ in substitution (s///) at - line 20. -Use of uninitialized value $m1 in regexp compilation at - line 21. -Use of uninitialized value $_ in substitution (s///) at - line 21. -Use of uninitialized value $_ in substitution (s///) at - line 21. -Use of uninitialized value $_ in substitution (s///) at - line 22. -Use of uninitialized value $_ in substitution (s///) at - line 22. +Use of uninitialized value $g2 in pattern match (m//) at - line 16. +Use of uninitialized value $m1 in regexp compilation at - line 17. +Use of uninitialized value $g2 in pattern match (m//) at - line 17. +Use of uninitialized value $g1 in regexp compilation at - line 18. +Use of uninitialized value $g2 in pattern match (m//) at - line 18. +Use of uninitialized value $g2 in substitution (s///) at - line 19. +Use of uninitialized value $m1 in regexp compilation at - line 20. +Use of uninitialized value $g2 in substitution (s///) at - line 20. +Use of uninitialized value $g2 in substitution (s///) at - line 20. +Use of uninitialized value $g2 in substitution (s///) at - line 21. +Use of uninitialized value $g2 in substitution (s///) at - line 21. +Use of uninitialized value $g1 in substitution iterator at - line 21. +Use of uninitialized value $m1 in regexp compilation at - line 22. +Use of uninitialized value $g2 in substitution (s///) at - line 22. +Use of uninitialized value $g2 in substitution (s///) at - line 22. Use of uninitialized value $g1 in substitution iterator at - line 22. -Use of uninitialized value $m1 in regexp compilation at - line 23. -Use of uninitialized value $_ in substitution (s///) at - line 23. -Use of uninitialized value $_ in substitution (s///) at - line 23. -Use of uninitialized value $g1 in substitution iterator at - line 23. -Use of uninitialized value $_ in transliteration (tr///) at - line 24. -Use of uninitialized value $_ in transliteration (tr///) at - line 25. -Use of uninitialized value $g2 in pattern match (m//) at - line 27. -Use of uninitialized value $m1 in regexp compilation at - line 28. -Use of uninitialized value $g2 in pattern match (m//) at - line 28. -Use of uninitialized value $g1 in regexp compilation at - line 29. -Use of uninitialized value $g2 in pattern match (m//) at - line 29. -Use of uninitialized value $g2 in substitution (s///) at - line 30. -Use of uninitialized value $m1 in regexp compilation at - line 31. -Use of uninitialized value $g2 in substitution (s///) at - line 31. -Use of uninitialized value $g2 in substitution (s///) at - line 31. -Use of uninitialized value $g2 in substitution (s///) at - line 32. -Use of uninitialized value $g2 in substitution (s///) at - line 32. +Use of uninitialized value in transliteration (tr///) at - line 23. +Use of uninitialized value in transliteration (tr///) at - line 24. +Use of uninitialized value $m1 in regexp compilation at - line 27. +Use of uninitialized value $g1 in regexp compilation at - line 28. +Use of uninitialized value $m1 in regexp compilation at - line 30. +Use of uninitialized value $g1 in substitution iterator at - line 31. +Use of uninitialized value $m1 in regexp compilation at - line 32. Use of uninitialized value $g1 in substitution iterator at - line 32. -Use of uninitialized value $m1 in regexp compilation at - line 33. -Use of uninitialized value $g2 in substitution (s///) at - line 33. -Use of uninitialized value $g2 in substitution (s///) at - line 33. -Use of uninitialized value $g1 in substitution iterator at - line 33. -Use of uninitialized value in transliteration (tr///) at - line 34. -Use of uninitialized value in transliteration (tr///) at - line 35. -Use of uninitialized value $m1 in regexp compilation at - line 38. -Use of uninitialized value $g1 in regexp compilation at - line 39. -Use of uninitialized value $m1 in regexp compilation at - line 41. -Use of uninitialized value $g1 in substitution iterator at - line 42. -Use of uninitialized value $m1 in regexp compilation at - line 43. -Use of uninitialized value $g1 in substitution iterator at - line 43. -Use of uninitialized value $m1 in substitution (s///) at - line 44. -Use of uninitialized value in substitution iterator at - line 47. -Use of uninitialized value $m1 in transliteration (tr///) at - line 49. -Use of uninitialized value $m1 in transliteration (tr///) at - line 50. +Use of uninitialized value $m1 in substitution (s///) at - line 33. +Use of uninitialized value in substitution iterator at - line 36. +Use of uninitialized value $m1 in transliteration (tr///) at - line 38. +Use of uninitialized value $m1 in transliteration (tr///) at - line 39. ######## use warnings 'uninitialized'; my ($m1); diff --git a/t/lib/warnings/op b/t/lib/warnings/op index d2f8e57..b253741 100644 --- a/t/lib/warnings/op +++ b/t/lib/warnings/op @@ -1,8 +1,5 @@ op.c AOK - Use of my $_ is experimental - my $_ ; - Found = in conditional, should be == 1 if $a = 1 ; @@ -105,17 +102,6 @@ __END__ # op.c -use warnings 'experimental::lexical_topic' ; -my $_; -CORE::state $_; -no warnings 'experimental::lexical_topic' ; -my $_; -CORE::state $_; -EXPECT -Use of my $_ is experimental at - line 3. -Use of state $_ is experimental at - line 4. -######## -# op.c use warnings 'syntax' ; 1 if $a = 1 ; 1 if $a diff --git a/t/lib/warnings/regexec b/t/lib/warnings/regexec index 1f3b65b..900dd6e 100644 --- a/t/lib/warnings/regexec +++ b/t/lib/warnings/regexec @@ -212,6 +212,7 @@ Use of \b{} or \B{} for non-UTF-8 locale is wrong. Assuming a UTF-8 locale at - Use of \b{} or \B{} for non-UTF-8 locale is wrong. Assuming a UTF-8 locale at - line 16. Use of \b{} or \B{} for non-UTF-8 locale is wrong. Assuming a UTF-8 locale at - line 17. Use of \b{} or \B{} for non-UTF-8 locale is wrong. Assuming a UTF-8 locale at - line 17. +Use of \b{} or \B{} for non-UTF-8 locale is wrong. Assuming a UTF-8 locale at - line 17. ######## # NAME (?[ ]) in non-UTF-8 locale eval { require POSIX; POSIX->import("locale_h") }; diff --git a/t/lib/warnings/utf8 b/t/lib/warnings/utf8 index 955ac55..809785b 100644 --- a/t/lib/warnings/utf8 +++ b/t/lib/warnings/utf8 @@ -408,43 +408,43 @@ close $fh; EXPECT Unicode surrogate U+D800 is illegal in UTF-8 at - line 6. Unicode surrogate U+DFFF is illegal in UTF-8 at - line 7. -Unicode non-character U+FDD0 is not recommended for open interchange at - line 10. -Unicode non-character U+FDEF is not recommended for open interchange at - line 11. -Unicode non-character U+FFFE is not recommended for open interchange at - line 15. -Unicode non-character U+FFFF is not recommended for open interchange at - line 16. -Unicode non-character U+1FFFE is not recommended for open interchange at - line 18. -Unicode non-character U+1FFFF is not recommended for open interchange at - line 19. -Unicode non-character U+2FFFE is not recommended for open interchange at - line 20. -Unicode non-character U+2FFFF is not recommended for open interchange at - line 21. -Unicode non-character U+3FFFE is not recommended for open interchange at - line 22. -Unicode non-character U+3FFFF is not recommended for open interchange at - line 23. -Unicode non-character U+4FFFE is not recommended for open interchange at - line 24. -Unicode non-character U+4FFFF is not recommended for open interchange at - line 25. -Unicode non-character U+5FFFE is not recommended for open interchange at - line 26. -Unicode non-character U+5FFFF is not recommended for open interchange at - line 27. -Unicode non-character U+6FFFE is not recommended for open interchange at - line 28. -Unicode non-character U+6FFFF is not recommended for open interchange at - line 29. -Unicode non-character U+7FFFE is not recommended for open interchange at - line 30. -Unicode non-character U+7FFFF is not recommended for open interchange at - line 31. -Unicode non-character U+8FFFE is not recommended for open interchange at - line 32. -Unicode non-character U+8FFFF is not recommended for open interchange at - line 33. -Unicode non-character U+9FFFE is not recommended for open interchange at - line 34. -Unicode non-character U+9FFFF is not recommended for open interchange at - line 35. -Unicode non-character U+AFFFE is not recommended for open interchange at - line 36. -Unicode non-character U+AFFFF is not recommended for open interchange at - line 37. -Unicode non-character U+BFFFE is not recommended for open interchange at - line 38. -Unicode non-character U+BFFFF is not recommended for open interchange at - line 39. -Unicode non-character U+CFFFE is not recommended for open interchange at - line 40. -Unicode non-character U+CFFFF is not recommended for open interchange at - line 41. -Unicode non-character U+DFFFE is not recommended for open interchange at - line 42. -Unicode non-character U+DFFFF is not recommended for open interchange at - line 43. -Unicode non-character U+EFFFE is not recommended for open interchange at - line 44. -Unicode non-character U+EFFFF is not recommended for open interchange at - line 45. -Unicode non-character U+FFFFE is not recommended for open interchange at - line 46. -Unicode non-character U+FFFFF is not recommended for open interchange at - line 47. -Unicode non-character U+10FFFE is not recommended for open interchange at - line 49. -Unicode non-character U+10FFFF is not recommended for open interchange at - line 50. -Code point 0x110000 is not Unicode, may not be portable at - line 51. +Unicode non-character U+FDD0 is not recommended for open interchange in print at - line 10. +Unicode non-character U+FDEF is not recommended for open interchange in print at - line 11. +Unicode non-character U+FFFE is not recommended for open interchange in print at - line 15. +Unicode non-character U+FFFF is not recommended for open interchange in print at - line 16. +Unicode non-character U+1FFFE is not recommended for open interchange in print at - line 18. +Unicode non-character U+1FFFF is not recommended for open interchange in print at - line 19. +Unicode non-character U+2FFFE is not recommended for open interchange in print at - line 20. +Unicode non-character U+2FFFF is not recommended for open interchange in print at - line 21. +Unicode non-character U+3FFFE is not recommended for open interchange in print at - line 22. +Unicode non-character U+3FFFF is not recommended for open interchange in print at - line 23. +Unicode non-character U+4FFFE is not recommended for open interchange in print at - line 24. +Unicode non-character U+4FFFF is not recommended for open interchange in print at - line 25. +Unicode non-character U+5FFFE is not recommended for open interchange in print at - line 26. +Unicode non-character U+5FFFF is not recommended for open interchange in print at - line 27. +Unicode non-character U+6FFFE is not recommended for open interchange in print at - line 28. +Unicode non-character U+6FFFF is not recommended for open interchange in print at - line 29. +Unicode non-character U+7FFFE is not recommended for open interchange in print at - line 30. +Unicode non-character U+7FFFF is not recommended for open interchange in print at - line 31. +Unicode non-character U+8FFFE is not recommended for open interchange in print at - line 32. +Unicode non-character U+8FFFF is not recommended for open interchange in print at - line 33. +Unicode non-character U+9FFFE is not recommended for open interchange in print at - line 34. +Unicode non-character U+9FFFF is not recommended for open interchange in print at - line 35. +Unicode non-character U+AFFFE is not recommended for open interchange in print at - line 36. +Unicode non-character U+AFFFF is not recommended for open interchange in print at - line 37. +Unicode non-character U+BFFFE is not recommended for open interchange in print at - line 38. +Unicode non-character U+BFFFF is not recommended for open interchange in print at - line 39. +Unicode non-character U+CFFFE is not recommended for open interchange in print at - line 40. +Unicode non-character U+CFFFF is not recommended for open interchange in print at - line 41. +Unicode non-character U+DFFFE is not recommended for open interchange in print at - line 42. +Unicode non-character U+DFFFF is not recommended for open interchange in print at - line 43. +Unicode non-character U+EFFFE is not recommended for open interchange in print at - line 44. +Unicode non-character U+EFFFF is not recommended for open interchange in print at - line 45. +Unicode non-character U+FFFFE is not recommended for open interchange in print at - line 46. +Unicode non-character U+FFFFF is not recommended for open interchange in print at - line 47. +Unicode non-character U+10FFFE is not recommended for open interchange in print at - line 49. +Unicode non-character U+10FFFF is not recommended for open interchange in print at - line 50. +Code point 0x110000 is not Unicode, may not be portable in print at - line 51. ######## require "../test.pl"; use warnings 'utf8'; @@ -456,8 +456,8 @@ print $fh "\x{110000}", "\n"; close $fh; EXPECT Unicode surrogate U+D800 is illegal in UTF-8 at - line 5. -Unicode non-character U+FFFF is not recommended for open interchange at - line 6. -Code point 0x110000 is not Unicode, may not be portable at - line 7. +Unicode non-character U+FFFF is not recommended for open interchange in print at - line 6. +Code point 0x110000 is not Unicode, may not be portable in print at - line 7. ######## require "../test.pl"; use warnings 'utf8'; @@ -469,8 +469,8 @@ print $fh "\x{FFFF}", "\n"; print $fh "\x{110000}", "\n"; close $fh; EXPECT -Unicode non-character U+FFFF is not recommended for open interchange at - line 7. -Code point 0x110000 is not Unicode, may not be portable at - line 8. +Unicode non-character U+FFFF is not recommended for open interchange in print at - line 7. +Code point 0x110000 is not Unicode, may not be portable in print at - line 8. ######## require "../test.pl"; use warnings 'utf8'; @@ -483,7 +483,7 @@ print $fh "\x{110000}", "\n"; close $fh; EXPECT Unicode surrogate U+D800 is illegal in UTF-8 at - line 6. -Code point 0x110000 is not Unicode, may not be portable at - line 8. +Code point 0x110000 is not Unicode, may not be portable in print at - line 8. ######## require "../test.pl"; use warnings 'utf8'; @@ -496,7 +496,7 @@ print $fh "\x{110000}", "\n"; close $fh; EXPECT Unicode surrogate U+D800 is illegal in UTF-8 at - line 6. -Unicode non-character U+FFFF is not recommended for open interchange at - line 7. +Unicode non-character U+FFFF is not recommended for open interchange in print at - line 7. ######## # NAME C works in isolation require "../test.pl"; @@ -506,7 +506,7 @@ open(my $fh, "+>:utf8", $file); print $fh "\x{FFFF}", "\n"; close $fh; EXPECT -Unicode non-character U+FFFF is not recommended for open interchange at - line 5. +Unicode non-character U+FFFF is not recommended for open interchange in print at - line 5. ######## # NAME C works in isolation require "../test.pl"; @@ -526,7 +526,7 @@ open(my $fh, "+>:utf8", $file); print $fh "\x{110000}", "\n"; close $fh; EXPECT -Code point 0x110000 is not Unicode, may not be portable at - line 5. +Code point 0x110000 is not Unicode, may not be portable in print at - line 5. ######## require "../test.pl"; no warnings 'utf8'; diff --git a/t/op/coreamp.t b/t/op/coreamp.t index b6c9487..7a99155 100644 --- a/t/op/coreamp.t +++ b/t/op/coreamp.t @@ -71,7 +71,7 @@ sub test_proto { if (!@_) { return } - $tests += 6; + $tests += 3; my($in,$out) = @_; # for testing implied $_ @@ -83,34 +83,6 @@ sub test_proto { $_ = $in; is &{"CORE::$o"}(), $out, "&$o with no args"; - - # Since there is special code to deal with lexical $_, make sure it - # works in all cases. - undef $_; - { - no warnings 'experimental::lexical_topic'; - my $_ = $in; - is &{"CORE::$o"}(), $out, "&$o with no args uses lexical \$_"; - } - # Make sure we get the right pad under recursion - my $r; - $r = sub { - if($_[0]) { - no warnings 'experimental::lexical_topic'; - my $_ = $in; - is &{"CORE::$o"}(), $out, - "&$o with no args uses the right lexical \$_ under recursion"; - } - else { - &$r(1) - } - }; - &$r(0); - no warnings 'experimental::lexical_topic'; - my $_ = $in; - eval { - is "CORE::$o"->(), $out, "&$o with the right lexical \$_ in an eval" - }; } elsif ($p =~ '^;([$*]+)\z') { # ;$ ;* ;$$ etc. my $maxargs = length $1; @@ -1062,8 +1034,7 @@ like $@, qr'^Undefined format "STDOUT" called', my $warnings; local $SIG{__WARN__} = sub { ++$warnings }; - no warnings 'experimental::lexical_topic'; - my $_ = 'Phoo'; + local $_ = 'Phoo'; ok &mymkdir(), '&mkdir'; like <*>, qr/^phoo(.DIR)?\z/i, 'mkdir works with implicit $_'; diff --git a/t/op/exec.t b/t/op/exec.t index 6ec3646..325ccb2 100644 --- a/t/op/exec.t +++ b/t/op/exec.t @@ -124,8 +124,7 @@ $Perl -le "print 'ok'" END { - no warnings 'experimental::lexical_topic'; - my $_ = qq($Perl -le "print 'ok'"); + local $_ = qq($Perl -le "print 'ok'"); is( readpipe, "ok\n", 'readpipe default argument' ); } diff --git a/t/op/goto.t b/t/op/goto.t index ca48ac0..d1e88d7 100644 --- a/t/op/goto.t +++ b/t/op/goto.t @@ -10,7 +10,7 @@ BEGIN { use warnings; use strict; -plan tests => 94; +plan tests => 96; our $TODO; my $deprecated = 0; @@ -414,6 +414,38 @@ moretests: } } +# This bug was introduced in Aug 2010 by commit ac56e7de46621c6f +# Peephole optimise adjacent pairs of nextstate ops. +# and fixed in Oct 2014 by commit f5b5c2a37af87535 +# Simplify double-nextstate optimisation + +# The bug manifests as a warning +# Use of "goto" to jump into a construct is deprecated at t/op/goto.t line 442. +# and $out is undefined. Devel::Peek reveals that the lexical in the pad has +# been reset to undef. I infer that pp_goto thinks that it's leaving one scope +# and entering another, but I don't know *why* it thinks that. Whilst this bug +# has been fixed by Father C, because I don't understand why it happened, I am +# not confident that other related bugs remain (or have always existed). + +sub DEBUG_TIME() { + 0; +} + +{ + if (DEBUG_TIME) { + } + + { + my $out = ""; + $out .= 'perl rules'; + goto no_list; + no_list: + is($out, 'perl rules', '$out has not been erroneously reset to undef'); + }; +} + +is($deprecated, 0, 'no warning was emmitted'); + # deep recursion with gotos eventually caused a stack reallocation # which messed up buggy internals that didn't expect the stack to move diff --git a/t/op/magic.t b/t/op/magic.t index 4a8006d..da7532e 100644 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; - plan (tests => 190); + plan (tests => 192); } # Test that defined() returns true for magic variables created on the fly, @@ -681,6 +681,27 @@ $_ = ${^E_NCODING}; pass('can read ${^E_NCODING} without blowing up'); is $_, undef, '${^E_NCODING} is undef'; +{ + my $warned = 0; + local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /Use of uninitialized value in unshift/; print "# @_"; }; + unshift @RT12608::A::ISA, qw(RT12608::B RT12608::C); + is $warned, 0, '[perl #126082] unshifting onto @ISA doesn\'t trigger set magic for each item'; +} + +{ + my $warned = 0; + local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /Use of uninitialized value in unshift/; print "# @_"; }; + + my $x; tie $x, 'RT12608::F'; + unshift @RT12608::X::ISA, $x, "RT12608::Z"; + is $warned, 0, '[perl #126082] PL_delaymagic correctly/saved restored when pushing/unshifting onto @ISA'; + + package RT12608::F; + use parent 'Tie::Scalar'; + sub TIESCALAR { bless {}; } + sub FETCH { push @RT12608::G::ISA, "RT12608::H"; "RT12608::Y"; } +} + # ^^^^^^^^^ New tests go here ^^^^^^^^^ SKIP: { diff --git a/t/op/mkdir.t b/t/op/mkdir.t index 35e4773..d37acc6 100644 --- a/t/op/mkdir.t +++ b/t/op/mkdir.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 22; +plan tests => 17; unless (eval { require File::Path; @@ -58,13 +58,3 @@ ok(-d); ok(rmdir); ok(!-d); $_ = 'lfrulb'; - -{ - no warnings 'experimental::lexical_topic'; - my $_ = 'blurfl'; - ok(mkdir); - ok(-d); - ok(-d 'blurfl'); - ok(!-d 'lfrulb'); - ok(rmdir); -} diff --git a/t/op/mydef.t b/t/op/mydef.t index b993f1b..11b55dd 100644 --- a/t/op/mydef.t +++ b/t/op/mydef.t @@ -7,212 +7,8 @@ BEGIN { } use strict; -no warnings 'misc', 'experimental::lexical_topic'; -$_ = 'global'; -is($_, 'global', '$_ initial value'); -s/oba/abo/; -is($_, 'glabol', 's/// on global $_'); - -{ - my $_ = 'local'; - is($_, 'local', 'my $_ initial value'); - s/oca/aco/; - is($_, 'lacol', 's/// on my $_'); - /(..)/; - is($1, 'la', '// on my $_'); - cmp_ok(tr/c/d/, '==', 1, 'tr/// on my $_ counts correctly' ); - is($_, 'ladol', 'tr/// on my $_'); - { - my $_ = 'nested'; - is($_, 'nested', 'my $_ nested'); - chop; - is($_, 'neste', 'chop on my $_'); - } - { - our $_; - is($_, 'glabol', 'gains access to our global $_'); - } - is($_, 'ladol', 'my $_ restored'); -} -is($_, 'glabol', 'global $_ restored'); -s/abo/oba/; -is($_, 'global', 's/// on global $_ again'); -{ - my $_ = 11; - our $_ = 22; - is($_, 22, 'our $_ is seen explicitly'); - chop; - is($_, 2, '...default chop chops our $_'); - /(.)/; - is($1, 2, '...default match sees our $_'); -} - -$_ = "global"; -{ - my $_ = 'local'; - for my $_ ("foo") { - is($_, "foo", 'for my $_'); - /(.)/; - is($1, "f", '...m// in for my $_'); - is(our $_, 'global', '...our $_ inside for my $_'); - } - is($_, 'local', '...my $_ restored outside for my $_'); - is(our $_, 'global', '...our $_ restored outside for my $_'); -} -{ - my $_ = 'local'; - for ("implicit foo") { # implicit "my $_" - is($_, "implicit foo", 'for implicit my $_'); - /(.)/; - is($1, "i", '...m// in for implicit my $_'); - is(our $_, 'global', '...our $_ inside for implicit my $_'); - } - is($_, 'local', '...my $_ restored outside for implicit my $_'); - is(our $_, 'global', '...our $_ restored outside for implicit my $_'); -} -{ - my $_ = 'local'; - is($_, "postfix foo", 'postfix for' ) for 'postfix foo'; - is($_, 'local', '...my $_ restored outside postfix for'); - is(our $_, 'global', '...our $_ restored outside postfix for'); -} -{ - for our $_ ("bar") { - is($_, "bar", 'for our $_'); - /(.)/; - is($1, "b", '...m// in for our $_'); - } - is($_, 'global', '...our $_ restored outside for our $_'); -} - -{ - my $buf = ''; - sub tmap1 { /(.)/; $buf .= $1 } # uses our $_ - my $_ = 'x'; - sub tmap2 { /(.)/; $buf .= $1 } # uses my $_ - map { - tmap1(); - tmap2(); - ok( /^[67]\z/, 'local lexical $_ is seen in map' ); - { is(our $_, 'global', 'our $_ still visible'); } - ok( $_ == 6 || $_ == 7, 'local lexical $_ is still seen in map' ); - { my $_ ; is($_, undef, 'nested my $_ is undefined'); } - } 6, 7; - is($buf, 'gxgx', q/...map doesn't modify outer lexical $_/); - is($_, 'x', '...my $_ restored outside map'); - is(our $_, 'global', '...our $_ restored outside map'); - map { my $_; is($_, undef, 'redeclaring $_ in map block undefs it'); } 1; -} -{ map { my $_; is($_, undef, 'declaring $_ in map block undefs it'); } 1; } -{ - sub tmap3 () { return $_ }; - my $_ = 'local'; - sub tmap4 () { return $_ }; - my $x = join '-', map $_.tmap3.tmap4, 1 .. 2; - is($x, '1globallocal-2globallocal', 'map without {}'); -} -{ - for my $_ (1) { - my $x = map $_, qw(a b); - is($x, 2, 'map in scalar context'); - } -} -{ - my $buf = ''; - sub tgrep1 { /(.)/; $buf .= $1 } - my $_ = 'y'; - sub tgrep2 { /(.)/; $buf .= $1 } - grep { - tgrep1(); - tgrep2(); - ok( /^[89]\z/, 'local lexical $_ is seen in grep' ); - { is(our $_, 'global', 'our $_ still visible'); } - ok( $_ == 8 || $_ == 9, 'local lexical $_ is still seen in grep' ); - } 8, 9; - is($buf, 'gygy', q/...grep doesn't modify outer lexical $_/); - is($_, 'y', '...my $_ restored outside grep'); - is(our $_, 'global', '...our $_ restored outside grep'); -} -{ - sub tgrep3 () { return $_ }; - my $_ = 'local'; - sub tgrep4 () { return $_ }; - my $x = join '-', grep $_=$_.tgrep3.tgrep4, 1 .. 2; - is($x, '1globallocal-2globallocal', 'grep without {} with side-effect'); - is($_, 'local', '...but without extraneous side-effects'); -} -{ - for my $_ (1) { - my $x = grep $_, qw(a b); - is($x, 2, 'grep in scalar context'); - } -} -{ - my $s = "toto"; - my $_ = "titi"; - my $r; - { - local $::TODO = 'Marked as todo since test was added in 59f00321bbc2d046'; - $r = $s =~ /to(?{ is($_, 'toto', 'my $_ in code-match' ) })to/; - } - ok($r, "\$s=$s should match!"); - is(our $_, 'global', '...our $_ restored outside code-match'); -} - -{ - my $_ = "abc"; - my $x = reverse; - is($x, "cba", 'reverse without arguments picks up $_'); -} - -{ - package notmain; - our $_ = 'notmain'; - ::is($::_, 'notmain', 'our $_ forced into main::'); - /(.*)/; - ::is($1, 'notmain', '...m// defaults to our $_ in main::'); -} - -my $file = tempfile(); -{ - open my $_, '>', $file or die "Can't open $file: $!"; - print $_ "hello\n"; - close $_; - cmp_ok(-s $file, '>', 5, 'writing to filehandle $_ works'); -} -{ - open my $_, $file or die "Can't open $file: $!"; - my $x = <$_>; - is($x, "hello\n", 'reading from <$_> works'); - close $_; -} - -{ - $fqdb::_ = 'fqdb'; - is($fqdb::_, 'fqdb', 'fully qualified $_ is not in main' ); - is(eval q/$fqdb::_/, 'fqdb', 'fully qualified, evaled $_ is not in main' ); - package fqdb; - ::isnt($_, 'fqdb', 'unqualified $_ is in main' ); - ::isnt(eval q/$_/, 'fqdb', 'unqualified, evaled $_ is in main'); -} - -{ - $clank_est::qunckkk = 3; - our $qunckkk; - $qunckkk = 4; - package clank_est; - our $qunckkk; - ::is($qunckkk, 3, 'regular variables are not forced to main'); -} - -{ - $whack::_ = 3; - our $_; - $_ = 4; - package whack; - our $_; - ::is($_, 4, '$_ is "special", and always forced to main'); -} +eval 'my $_'; +like $@, qr/^Can't use global \$_ in "my" at /; done_testing(); diff --git a/t/op/override.t b/t/op/override.t index ff43571..e660311 100644 --- a/t/op/override.t +++ b/t/op/override.t @@ -8,7 +8,7 @@ BEGIN { require 'Config_heavy.pl'; # since runperl will need them } -plan tests => 37; +plan tests => 36; # # This file tries to test builtin override using CORE::GLOBAL @@ -64,17 +64,6 @@ is( $r, join($dirsep, "Foo", "Bar.pm") ); is( $r, 'foo.pm' ); } -{ - BEGIN { - # Can’t do ‘no warnings’ with CORE::GLOBAL::require overridden. :-) - CORE::require warnings; - unimport warnings 'experimental::lexical_topic'; - } - my $_ = 'bar.pm'; - require; - is( $r, 'bar.pm' ); -} - # localizing *CORE::GLOBAL::foo should revert to finding CORE::foo { local(*CORE::GLOBAL::require); diff --git a/t/op/pack.t b/t/op/pack.t index 1b0fd0d..e348693 100644 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -936,10 +936,7 @@ is("@{[unpack('U*', pack('U*', 100, 200, 300))]}", "100 200 300"); # is unpack U the reverse of pack U for byte string? is("@{[unpack('U*', pack('U*', 100, 200))]}", "100 200"); - -SKIP: { - skip "Two of these still fail on EBCDIC; investigate in v5.23", 3 if $::IS_EBCDIC; - +{ # does pack U0C create Unicode? my $cp202 = chr(202); utf8::upgrade $cp202; @@ -948,10 +945,15 @@ SKIP: { use bytes; @bytes202 = map { ord } split "", $cp202; } - is("@{[pack('U0C*', 100, @bytes202)]}", v100.v202); + + # This test requires the first number to be invariant; 64 is invariant on + # ASCII and EBCDIC. + is("@{[pack('U0C*', 64, @bytes202)]}", v64.v202); # does pack C0U create characters? - is("@{[pack('C0U*', 100, 202)]}", pack("C*", 100, @bytes202)); + # The U* is expecting Unicode, so convert to that. + is("@{[pack('C0U*', map { utf8::native_to_unicode($_) } 64, 202)]}", + pack("C*", 64, @bytes202)); # does unpack U0U on byte data warn? { @@ -1533,26 +1535,28 @@ is(unpack('c'), 65, "one-arg unpack (change #18751)"); # defaulting to $_ is(unpack("C0%128U", "abcd"), unpack("U0%128U", "abcd"), "checksum not overflowed"); } -my $U_1FFC_utf8 = byte_utf8a_to_utf8n("\341\277\274"); -my $first_byte = ord uni_to_native("\341"); +my $U_1FFC_bytes = byte_utf8a_to_utf8n("\341\277\274"); { # U0 and C0 must be scoped - my (@x) = unpack("a(U0)U", "b$U_1FFC_utf8"); + my (@x) = unpack("a(U0)U", "b$U_1FFC_bytes"); is($x[0], 'b', 'before scope'); is($x[1], 8188, 'after scope'); - is(pack("a(U0)U", "b", 8188), "b$U_1FFC_utf8"); + is(pack("a(U0)U", "b", 8188), "b$U_1FFC_bytes"); } -SKIP: { # counted length prefixes shouldn't change C0/U0 mode - # (note the length is actually 0 in this test) - is(join(',', unpack("aC/UU", "b\0$U_1FFC_utf8")), 'b,8188'); - is(join(',', unpack("aC/CU", "b\0$U_1FFC_utf8")), 'b,8188'); - skip "These two still fail on EBCDIC; investigate in v5.23", 2 if $::IS_EBCDIC; - is(join(',', unpack("aU0C/UU", "b\0$U_1FFC_utf8")), "b,$first_byte"); - is(join(',', unpack("aU0C/CU", "b\0$U_1FFC_utf8")), "b,$first_byte"); + # (note the length is actually 0 in this test, as the C/ is replaced by C0 + # due to the \0 in the string) + is(join(',', unpack("aC/UU", "b\0$U_1FFC_bytes")), 'b,8188'); + is(join(',', unpack("aC/CU", "b\0$U_1FFC_bytes")), 'b,8188'); + + # The U expects Unicode, so convert from native + my $first_byte = utf8::native_to_unicode(ord substr($U_1FFC_bytes, 0, 1)); + + is(join(',', unpack("aU0C/UU", "b\0$U_1FFC_bytes")), "b,$first_byte"); + is(join(',', unpack("aU0C/CU", "b\0$U_1FFC_bytes")), "b,$first_byte"); } { diff --git a/t/op/reverse.t b/t/op/reverse.t index 059ece2..74e6295 100644 --- a/t/op/reverse.t +++ b/t/op/reverse.t @@ -6,7 +6,7 @@ BEGIN { set_up_inc('../lib'); } -plan tests => 26; +plan tests => 23; is(reverse("abc"), "cba", 'simple reverse'); @@ -91,16 +91,3 @@ use Tie::Array; my $c = scalar reverse($b); is($a, $c, 'Unicode string double reversal matches original'); } - -{ - # Lexical $_. - no warnings 'experimental::lexical_topic'; - sub blurp { my $_ = shift; reverse } - - is(blurp("foo"), "oof", 'reversal of default variable in function'); - is(sub { my $_ = shift; reverse }->("bar"), "rab", 'reversal of default variable in anonymous function'); - { - local $_ = "XXX"; - is(blurp("paz"), "zap", 'reversal of default variable with local value set' ); - } -} diff --git a/t/op/sigdispatch.t b/t/op/sigdispatch.t index 9808f7b..242fb8e 100644 --- a/t/op/sigdispatch.t +++ b/t/op/sigdispatch.t @@ -44,8 +44,9 @@ SKIP: { skip('We can\'t test blocking without sigprocmask', 17) if is_miniperl() || !$Config{d_sigprocmask}; skip("This doesn\'t work on $^O threaded builds RT#88814", 17) - if ($^O =~ /cygwin/ || $^O eq "openbsd" && $Config{osvers} < 5.2) - && $Config{useithreads}; + if ($^O =~ /cygwin/ && $Config{useithreads}); + skip("This doesn\'t work on $^O version $Config{osvers} RT#88814", 17) + if ($^O eq "openbsd" && $Config{osvers} < 5.2); require POSIX; my $pending = POSIX::SigSet->new(); diff --git a/t/op/signatures.t b/t/op/signatures.t index e1c3140..217efa3 100644 --- a/t/op/signatures.t +++ b/t/op/signatures.t @@ -1091,24 +1091,6 @@ like $@, qr/\AParse error at foo line 8\.\n/; eval "#line 8 foo\nsub t099 (\$\$) { }"; like $@, qr/\AParse error at foo line 8\.\n/; -no warnings "experimental::lexical_topic"; -sub t100 ($_) { "$::_/$_" } -is prototype(\&t100), undef; -$_ = "___"; -is eval("t100()"), undef; -like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/; -$_ = "___"; -is eval("t100(0)"), "___/0"; -$_ = "___"; -is eval("t100(456)"), "___/456"; -$_ = "___"; -is eval("t100(456, 789)"), undef; -like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/; -$_ = "___"; -is eval("t100(456, 789, 987)"), undef; -like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/; -is $a, 123; - eval "#line 8 foo\nsub t101 (\@_) { }"; like $@, qr/\ACan't use global \@_ in "my" at foo line 8/; diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t index 023167b..a898df1 100644 --- a/t/op/sprintf2.t +++ b/t/op/sprintf2.t @@ -577,6 +577,7 @@ is $o::count, 0, 'sprintf %d string overload count is 0'; is $o::numcount, 1, 'sprintf %d number overload count is 1'; my $ppc64_linux = $Config{archname} =~ /^ppc64-linux/; +my $irix_ld = $Config{archname} =~ /^IP\d+-irix-ld$/; for my $t (@hexfloat) { my ($format, $arg, $expected) = @$t; @@ -589,6 +590,15 @@ for my $t (@hexfloat) { ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); next; } + if ($doubledouble && $irix_ld && $arg =~ /^1.41421/) { + # irix has buggy sqrt(2), + # last hexdigit one bit error: + # gets '0x1.6a09e667f3bcc908b2fb1366eacp+0' + # wants '0x1.6a09e667f3bcc908b2fb1366ea8p+0' + local $::TODO = "$Config{archname} sqrt(2)"; + ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); + next; + } unless ($ok) { # It seems that there can be difference in the last bits: # [perl #122578] diff --git a/t/op/state.t b/t/op/state.t index 81e5486..ed68b51 100644 --- a/t/op/state.t +++ b/t/op/state.t @@ -9,7 +9,7 @@ BEGIN { use strict; -plan tests => 137; +plan tests => 124; # Before loading feature.pm, test it with CORE:: ok eval 'CORE::state $x = 1;', 'CORE::state outside of feature.pm scope'; @@ -204,22 +204,6 @@ $y = 0; # -# Check state $_ -# -my @stones = qw [fred wilma barny betty]; -my $first = $stones [0]; -my $First = ucfirst $first; -$_ = "bambam"; -foreach my $flint (@stones) { - no warnings 'experimental::lexical_topic'; - state $_ = $flint; - is $_, $first, 'state $_'; - ok /$first/, '/.../ binds to $_'; - is ucfirst, $First, '$_ default argument'; -} -is $_, "bambam", '$_ is still there'; - -# # Goto. # my @simpsons = qw [Homer Marge Bart Lisa Maggie]; diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t index ab9faac..f70e6fe 100644 --- a/t/op/sub_lval.t +++ b/t/op/sub_lval.t @@ -169,7 +169,7 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/); +like($_, qr/Can\'t modify non-lvalue subroutine call of &main::nolv in scalar assignment/); $_ = ''; @@ -178,7 +178,7 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/); +like($_, qr/Can\'t modify non-lvalue subroutine call of &main::nolv in scalar assignment/); $_ = ''; @@ -187,7 +187,7 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can\'t modify non-lvalue subroutine call in scalar assignment/); +like($_, qr/Can\'t modify non-lvalue subroutine call of &main::nolv in scalar assignment/); $x0 = $x1 = $_ = undef; $nolv = \&nolv; @@ -358,7 +358,7 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can\'t modify non-lvalue subroutine call at /); +like($_, qr/Can\'t modify non-lvalue subroutine call of &main::xxx at /); $_ = undef; eval <<'EOE' or $_ = $@; @@ -366,7 +366,7 @@ eval <<'EOE' or $_ = $@; 1; EOE -like($_, qr/Can\'t modify non-lvalue subroutine call at /); +like($_, qr/Can\'t modify non-lvalue subroutine call of &main::xxx at /); sub yyy () { 'yyy' } # Const, not lvalue @@ -823,7 +823,7 @@ foo = 3; ---- lvalue attribute ignored after the subroutine has been defined at - line 4. lvalue attribute ignored after the subroutine has been defined at - line 6. -Can't modify non-lvalue subroutine call in scalar assignment at - line 7, near "3;" +Can't modify non-lvalue subroutine call of &main::foo in scalar assignment at - line 7, near "3;" Execution of - aborted due to compilation errors. ==== } @@ -979,7 +979,7 @@ package _102486 { 'sub:lvalue{&$x}->() does not die for non-lvalue inner sub call'; ::is $called, 1, 'The &$x actually called the sub'; eval { +sub :lvalue { &$x }->() = 3 }; - ::like $@, qr/^Can't modify non-lvalue subroutine call at /, + ::like $@, qr/^Can't modify non-lvalue subroutine call of &_102486::nonlv at /, 'sub:lvalue{&$x}->() dies in true lvalue context'; } @@ -1008,7 +1008,7 @@ for (sub : lvalue { "$x" }->()) { # [perl #117947] XSUBs should not be treated as lvalues at run time eval { &{\&utf8::is_utf8}("") = 3 }; -like $@, qr/^Can't modify non-lvalue subroutine call at /, +like $@, qr/^Can't modify non-lvalue subroutine call of &utf8::is_utf8 at /, 'XSUB not seen at compile time dies in lvalue context'; # [perl #119797] else implicitly returning value diff --git a/t/op/switch.t b/t/op/switch.t index 204a57a..8e3851c 100644 --- a/t/op/switch.t +++ b/t/op/switch.t @@ -10,7 +10,7 @@ use strict; use warnings; no warnings 'experimental::smartmatch'; -plan tests => 201; +plan tests => 189; # The behaviour of the feature pragma should be tested by lib/feature.t # using the tests in t/lib/feature/*. This file tests the behaviour of @@ -55,15 +55,6 @@ $_ = "outside"; given("inside") { check_outside1() } sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") } -{ - no warnings 'experimental::lexical_topic'; - my $_ = "outside"; - given("inside") { check_outside2() } - sub check_outside2 { - is($_, "outside", "\$_ lexically scoped (lexical \$_)") - } -} - # Basic string/numeric comparisons and control flow { @@ -397,23 +388,6 @@ sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") } is($ok, "twenty", $test); } -# Make sure it still works with a lexical $_: -{ - no warnings 'experimental::lexical_topic'; - my $_; - my $test = "explicit comparison with lexical \$_"; - my $twenty_five = 25; - my $ok; - given($twenty_five) { - when ($_ ge "40") { $ok = "forty" } - when ($_ ge "30") { $ok = "thirty" } - when ($_ ge "20") { $ok = "twenty" } - when ($_ ge "10") { $ok = "ten" } - default { $ok = "default" } - } - is($ok, "twenty", $test); -} - # Optimized-away comparisons { my $ok; @@ -698,62 +672,6 @@ my $f = tie my $v, "FetchCounter"; } } -{ - my $first = 1; - no warnings 'experimental::lexical_topic'; - my $_; - for (1, "two") { - when ("two") { - is($first, 0, "Implicitly lexical loop: second"); - eval {break}; - like($@, qr/^Can't "break" in a loop topicalizer/, - q{Can't "break" in a loop topicalizer}); - } - when (1) { - is($first, 1, "Implicitly lexical loop: first"); - $first = 0; - # Implicit break is okay - } - } -} - -{ - my $first = 1; - no warnings 'experimental::lexical_topic'; - my $_; - for $_ (1, "two") { - when ("two") { - is($first, 0, "Implicitly lexical, explicit \$_: second"); - eval {break}; - like($@, qr/^Can't "break" in a loop topicalizer/, - q{Can't "break" in a loop topicalizer}); - } - when (1) { - is($first, 1, "Implicitly lexical, explicit \$_: first"); - $first = 0; - # Implicit break is okay - } - } -} - -{ - my $first = 1; - no warnings 'experimental::lexical_topic'; - for my $_ (1, "two") { - when ("two") { - is($first, 0, "Lexical loop: second"); - eval {break}; - like($@, qr/^Can't "break" in a loop topicalizer/, - q{Can't "break" in a loop topicalizer}); - } - when (1) { - is($first, 1, "Lexical loop: first"); - $first = 0; - # Implicit break is okay - } - } -} - # Code references { @@ -1371,23 +1289,13 @@ unreified_check(undef,""); # must ensure $_ is initialised and cleared at start/end of given block { - sub f1 { - no warnings 'experimental::lexical_topic'; - my $_; - given(3) { - return sub { $_ } # close over lexical $_ - } - } - is(f1()->(), 3, 'closed over $_'); - package RT94682; my $d = 0; sub DESTROY { $d++ }; sub f2 { - no warnings 'experimental::lexical_topic'; - my $_ = 5; + local $_ = 5; given(bless [7]) { ::is($_->[0], 7, "is [7]"); } diff --git a/t/perf/benchmarks b/t/perf/benchmarks index 7fcc1fd..9456a6e 100644 --- a/t/perf/benchmarks +++ b/t/perf/benchmarks @@ -236,6 +236,94 @@ }, + # using a const string as second arg to index triggers using FBM. + # the FBM matcher special-cases 1,2-byte strings. + # + 'expr::index::short_const1' => { + desc => 'index of a short string against a 1 char const substr', + setup => 'my $x = "aaaab"', + code => 'index $x, "b"', + }, + 'expr::index::long_const1' => { + desc => 'index of a long string against a 1 char const substr', + setup => 'my $x = "a" x 1000 . "b"', + code => 'index $x, "b"', + }, + 'expr::index::short_const2aabc_bc' => { + desc => 'index of a short string against a 2 char const substr', + setup => 'my $x = "aaaabc"', + code => 'index $x, "bc"', + }, + 'expr::index::long_const2aabc_bc' => { + desc => 'index of a long string against a 2 char const substr', + setup => 'my $x = "a" x 1000 . "bc"', + code => 'index $x, "bc"', + }, + 'expr::index::long_const2aa_ab' => { + desc => 'index of a long string aaa.. against const substr "ab"', + setup => 'my $x = "a" x 1000', + code => 'index $x, "ab"', + }, + 'expr::index::long_const2bb_ab' => { + desc => 'index of a long string bbb.. against const substr "ab"', + setup => 'my $x = "b" x 1000', + code => 'index $x, "ab"', + }, + 'expr::index::long_const2aa_bb' => { + desc => 'index of a long string aaa.. against const substr "bb"', + setup => 'my $x = "a" x 1000', + code => 'index $x, "bb"', + }, + # this one is designed to be pathological + 'expr::index::long_const2ab_aa' => { + desc => 'index of a long string abab.. against const substr "aa"', + setup => 'my $x = "ab" x 500', + code => 'index $x, "aa"', + }, + # near misses with gaps, 1st letter + 'expr::index::long_const2aaxx_xy' => { + desc => 'index of a long string with "xx"s against const substr "xy"', + setup => 'my $x = "aaaaaaaaxx" x 100', + code => 'index $x, "xy"', + }, + # near misses with gaps, 2nd letter + 'expr::index::long_const2aayy_xy' => { + desc => 'index of a long string with "yy"s against const substr "xy"', + setup => 'my $x = "aaaaaaaayy" x 100', + code => 'index $x, "xy"', + }, + # near misses with gaps, duplicate letter + 'expr::index::long_const2aaxy_xx' => { + desc => 'index of a long string with "xy"s against const substr "xx"', + setup => 'my $x = "aaaaaaaaxy" x 100', + code => 'index $x, "xx"', + }, + # alternating near misses with gaps + 'expr::index::long_const2aaxxaayy_xy' => { + desc => 'index of a long string with "xx/yy"s against const substr "xy"', + setup => 'my $x = "aaaaaaaaxxbbbbbbbbyy" x 50', + code => 'index $x, "xy"', + }, + 'expr::index::short_const3aabcd_bcd' => { + desc => 'index of a short string against a 3 char const substr', + setup => 'my $x = "aaaabcd"', + code => 'index $x, "bcd"', + }, + 'expr::index::long_const3aabcd_bcd' => { + desc => 'index of a long string against a 3 char const substr', + setup => 'my $x = "a" x 1000 . "bcd"', + code => 'index $x, "bcd"', + }, + 'expr::index::long_const3ab_abc' => { + desc => 'index of a long string of "ab"s against a 3 char const substr "abc"', + setup => 'my $x = "ab" x 500', + code => 'index $x, "abc"', + }, + 'expr::index::long_const3bc_abc' => { + desc => 'index of a long string of "bc"s against a 3 char const substr "abc"', + setup => 'my $x = "bc" x 500', + code => 'index $x, "abc"', + }, 'expr::index::utf8_position_1' => { desc => 'index of a utf8 string, matching at position 1', setup => 'my $x = "abc". chr(0x100); chop $x', diff --git a/t/porting/customized.dat b/t/porting/customized.dat index 190161c..89268ac 100644 --- a/t/porting/customized.dat +++ b/t/porting/customized.dat @@ -1,9 +1,13 @@ CPAN cpan/CPAN/lib/CPAN.pm ce62c43d72f101c011184dbbc59e21c2790826f0 -Compress::Raw::Zlib cpan/Compress-Raw-Zlib/Zlib.xs 50a0176905a1702caef88abf268e0b60ae1f7382 +Encode cpan/Encode/Encode.xs ef106510cceba35eaae4c52127116162f5d7260f +Encode cpan/Encode/encoding.pm 51c19efc9bfe8467d6ae12a4654f6e7f980715bf +Encode cpan/Encode/Unicode/Unicode.xs c7ab75e09f6b2685060d3c0bd091862fc2d31724 ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm fd048a43fc1a53acbe133bd96ddbf1421cfb28cf ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm 0c78ba02d6249dfcca12ac9886a7c7cfb60e77fe ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/prereq.t 53bda2c549fd13a6b6c13a070ca6bc79883081c0 ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/vstrings.t 90035a2bdbf45f15b9c3196d072d7cba7e662871 +Math::BigRat cpan/Math-BigRat/lib/Math/BigRat.pm 682352dde33638125ce12ca44990bd1cd44af4f8 +Module::Metadata cpan/Module-Metadata/t/lib/GeneratePackage.pm 502ffbe2609947430e6aa1a3df8064b3fef3e086 Pod::Perldoc cpan/Pod-Perldoc/lib/Pod/Perldoc.pm dcd53fba13060dbb71b1b5861fbc5c0881c8625a Pod::Simple cpan/Pod-Simple/lib/Pod/Simple/BlackBox.pm 4108633c4f40f7f63c5a0245df2b07a4a2f22fec Pod::Simple cpan/Pod-Simple/lib/Pod/Simple/Search.pm 7a48823f9faec6d6bbef08060e679e46ccf60bc8 @@ -18,7 +22,8 @@ Scalar-List-Utils cpan/Scalar-List-Utils/lib/List/Util/XS.pm 08abbe1a707927cee53 Scalar-List-Utils cpan/Scalar-List-Utils/lib/Scalar/Util.pm 7f1e6eb11105623200ef9cdcb881545ccb769ded Scalar-List-Utils cpan/Scalar-List-Utils/lib/Sub/Util.pm d87811528ae3587f04e2f09894b8c88471754386 Scalar-List-Utils cpan/Scalar-List-Utils/ListUtil.xs ed25abc419771d6f3f12323f1f0a372f043d51b2 -Socket cpan/Socket/Socket.xs ae3f68904b11389da5442319cb15918b629d86b4 +Socket cpan/Socket/Socket.pm bdc42a2bd5cb560ed1120a3e6f408ed7ece14dce +Socket cpan/Socket/Socket.xs 6102315291684e56e360ff5e0dd237c9394c49b8 Text::ParseWords cpan/Text-ParseWords/t/ParseWords.t 9bae51c9b944cd5c0bbabe9d397e573976a2be8e Win32API::File cpan/Win32API-File/buffers.h 02d230ac9ac7091365128161a0ed671898baefae Win32API::File cpan/Win32API-File/cFile.h fca7e383e76979c3ac3adf12d11d1bcd2618e489 diff --git a/t/porting/known_pod_issues.dat b/t/porting/known_pod_issues.dat index 62c1d5a..5bab62e 100644 --- a/t/porting/known_pod_issues.dat +++ b/t/porting/known_pod_issues.dat @@ -273,7 +273,7 @@ pod/perlcygwin.pod Verbatim line length including indents exceeds 79 by 20 pod/perldebguts.pod Verbatim line length including indents exceeds 79 by 27 pod/perldebtut.pod Verbatim line length including indents exceeds 79 by 3 pod/perldtrace.pod Verbatim line length including indents exceeds 79 by 7 -pod/perlgit.pod Verbatim line length including indents exceeds 79 by 11 +pod/perlgit.pod Verbatim line length including indents exceeds 79 by 12 pod/perlguts.pod ? Should you be using L<...> instead of 1 pod/perlguts.pod Verbatim line length including indents exceeds 79 by 1 pod/perlhack.pod ? Should you be using L<...> instead of 1 diff --git a/t/porting/maintainers.t b/t/porting/maintainers.t index f82656d..37e88ea 100644 --- a/t/porting/maintainers.t +++ b/t/porting/maintainers.t @@ -19,18 +19,18 @@ if ( $Config{usecrosscompile} ) { skip_all( "Odd failures during cross-compilation" ); } -if ($::IS_EBCDIC) { - skip_all("Fails on EBCDIC machines, prob. because of different sort order"); +if ( $Config{ccflags} =~ /-DPERL_EXTERNAL_GLOB/) { + skip_all "Maintainers doesn't currently work for '-DPERL_EXTERNAL_GLOB'"; } -use strict; -use warnings; -use Maintainers qw(show_results process_options finish_tap_output); - if ($^O eq 'VMS') { skip_all "home-grown glob doesn't handle fancy patterns"; } +use strict; +use warnings; +use Maintainers qw(show_results process_options finish_tap_output); + { local @ARGV = qw|--checkmani|; show_results(process_options()); diff --git a/t/re/pat.t b/t/re/pat.t index 3377b19..fb4caf6 100644 --- a/t/re/pat.t +++ b/t/re/pat.t @@ -23,7 +23,7 @@ BEGIN { skip_all_without_unicode_tables(); } -plan tests => 775; # Update this when adding/deleting tests. +plan tests => 776; # Update this when adding/deleting tests. run_tests() unless caller; @@ -1681,7 +1681,10 @@ EOP my $code=' BEGIN{require q(test.pl);} use Encode qw(_utf8_on); - my $malformed = "a\x80\n"; + # \x80 and \x41 are continuation bytes in their respective + # character sets + my $malformed = (ord("A") == 65) ? "a\x80\n" : "a\x41\n"; + utf8::downgrade($malformed); _utf8_on($malformed); watchdog(3); $malformed =~ /(\n\r|\r)$/; @@ -1708,6 +1711,16 @@ EOP like($error, qr{Reference to nonexistent group}, 'gave appropriate error for qr{()(?1)}n'); } + + { + # [perl #126406] panic with unmatchable quantifier + my $code=' + no warnings "regexp"; + "" =~ m/(.0\N{6,0}0\N{6,0}000000000000000000000000000000000)/; + '; + fresh_perl_is($code, "", {}, + "perl [#126406] panic"); + } } # End of sub run_tests 1; diff --git a/t/re/pat_advanced.t b/t/re/pat_advanced.t index e221ece..a32af20 100644 --- a/t/re/pat_advanced.t +++ b/t/re/pat_advanced.t @@ -15,6 +15,7 @@ BEGIN { use strict; use warnings; use 5.010; +our ($REGMARK, $REGERROR); sub run_tests; @@ -1286,7 +1287,7 @@ sub run_tests { { # Test named commits and the $REGERROR var - our $REGERROR; + local $REGERROR; for my $name ('', ':foo') { for my $pat ("(*PRUNE$name)", ($name ? "(*MARK$name)" : "") . "(*SKIP$name)", @@ -1305,6 +1306,7 @@ sub run_tests { # Test named commits and the $REGERROR var package Fnorble; our $REGERROR; + local $REGERROR; for my $name ('', ':foo') { for my $pat ("(*PRUNE$name)", ($name ? "(*MARK$name)" : "") . "(*SKIP$name)", @@ -1322,7 +1324,7 @@ sub run_tests { { # Test named commits and the $REGERROR var my $message = '$REGERROR'; - our $REGERROR; + local $REGERROR; for my $word (qw (bar baz bop)) { $REGERROR = ""; "aaaaa$word" =~ @@ -1392,7 +1394,8 @@ sub run_tests { { my $message = '$REGMARK'; our @r = (); - our ($REGMARK, $REGERROR); + local $REGMARK; + local $REGERROR; like('foofoo', qr/foo (*MARK:foo) (?{push @r,$REGMARK}) /x, $message); is("@r","foo", $message); is($REGMARK, "foo", $message); @@ -1659,8 +1662,8 @@ sub run_tests { { # Test for keys in %+ and %- my $message = 'Test keys in %+ and %-'; - no warnings 'uninitialized', 'deprecated', 'experimental::lexical_topic'; - my $_ = "abcdef"; + no warnings 'uninitialized'; + local $_ = "abcdef"; /(?a)|(?b)/; is((join ",", sort keys %+), "foo", $message); is((join ",", sort keys %-), "foo", $message); @@ -1680,8 +1683,7 @@ sub run_tests { { # length() on captures, the numbered ones end up in Perl_magic_len - no warnings 'deprecated', 'experimental::lexical_topic'; - my $_ = "aoeu " . uni_to_native("\xe6") . "var ook"; + local $_ = "aoeu " . uni_to_native("\xe6") . "var ook"; /^ \w+ \s (?\S+)/x; is(length $`, 0, q[length $`]); diff --git a/t/re/pat_rt_report.t b/t/re/pat_rt_report.t index f35e72c..05404c7 100644 --- a/t/re/pat_rt_report.t +++ b/t/re/pat_rt_report.t @@ -856,8 +856,7 @@ sub run_tests { { my $message = '$REGMARK in replacement; Bug 49190'; our $REGMARK; - no warnings 'experimental::lexical_topic'; - my $_ = "A"; + local $_ = "A"; ok(s/(*:B)A/$REGMARK/, $message); is($_, "B", $message); $_ = "CCCCBAA"; diff --git a/t/re/qr.t b/t/re/qr.t index 811f5c5..f2082cd 100644 --- a/t/re/qr.t +++ b/t/re/qr.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 5; +plan tests => 4; my $rx = qr//; @@ -33,26 +33,6 @@ is(ref $rx, "Regexp", "qr// blessed into 'Regexp' by default"); is $output, "5\n1: 5\n2: 5\n", '$a_match_var =~ /$qr/'; } -no warnings 'experimental::lexical_topic'; -for my $_($'){ - my $output = ''; - my $rx = qr/o/; - my $a = "ooaoaoao"; - - my $foo = 0; - $foo += () = ($a =~ /$rx/g); - $output .= "$foo\n"; # correct - - $foo = 0; - for ($foo += ($a =~ /o/); $' && /o/ && ($foo++) ; ) { ; } - $output .= "1: $foo\n"; # No error - - $foo = 0; - for ($foo += ($a =~ /$rx/); $' && /$rx/ && ($foo++) ; ) { ; } - $output .= "2: $foo\n"; # initialization warning, incorrect results - - is $output, "5\n1: 5\n2: 5\n", '/$qr/ with my $_ aliased to a match var'; -} for($'){ my $output = ''; my $rx = qr/o/; diff --git a/t/re/re_tests b/t/re/re_tests index 9d5fa73..67ac57c 100644 --- a/t/re/re_tests +++ b/t/re/re_tests @@ -134,7 +134,14 @@ a[^]b]c adc y $& adc \By\b xy y - - \by\B yz y - - \By\B xyz y - - +\b n - - +\b{gcb} n - - +\b{sb} n - - +\b{wb} n - - \B y - - +\B{gcb} y - - +\B{sb} y - - +\B{wb} y - - \w a y - - \w - n - - \W a n - - @@ -1926,5 +1933,23 @@ A+(*PRUNE)BC(?{}) AAABC y $& AAABC /(a+){1}+a/ aaa n - - # [perl #125825] +^((?(?=x)xb|ya)z) xbz y $1 xbz +^((?(?=x)xb|ya)z) yaz y $1 yaz +^((?(?!y)xb|ya)z) xbz y $1 xbz +^((?(?!y)xb|ya)z) yaz y $1 yaz +^((?(?!)xb|ya)z) xbz n - - +^((?(?!)xb|ya)z) yaz y $1 yaz # [perl-126222] + +foo(*ACCEPT:foo) foo y $::REGMARK foo +(foo(*ACCEPT:foo)) foo y $::REGMARK foo +A(*FAIL:foo)[BC] A n $::REGERROR foo + +\N(?#comment){SPACE} A c - Missing braces on \N{} +ab(?#Comment){2}c abbc y $& abbc +\p A A c - Character following \\p must be '{' or a single-character Unicode property name # [perl #126187 +\P:A A c - Character following \\P must be '{' or a single-character Unicode property name +\p^ A c - Character following \\p must be '{' or a single-character Unicode property name +\PU A c - Can't find Unicode property definition \"U\" + # Keep these lines at the end of the file # vim: softtabstop=0 noexpandtab diff --git a/t/re/reg_mesg.t b/t/re/reg_mesg.t index dd82949..9e5a406 100644 --- a/t/re/reg_mesg.t +++ b/t/re/reg_mesg.t @@ -219,8 +219,8 @@ my @death = '/(?[ \cK + ) ])/' => 'Unexpected \')\' {#} m/(?[ \cK + ){#} ])/', '/(?[ \cK + ])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[ \cK + {#}])/', '/(?[ ( ) ])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[ ( ) {#}])/', - '/(?[ \p{foo} ])/' => 'Property \'foo\' is unknown {#} m/(?[ \p{foo}{#} ])/', - '/(?[ \p{ foo = bar } ])/' => 'Property \'foo = bar\' is unknown {#} m/(?[ \p{ foo = bar }{#} ])/', + '/(?[ \p{foo} ])/' => 'Can\'t find Unicode property definition "foo" {#} m/(?[ \p{foo}{#} ])/', + '/(?[ \p{ foo = bar } ])/' => 'Can\'t find Unicode property definition "foo = bar" {#} m/(?[ \p{ foo = bar }{#} ])/', '/(?[ \8 ])/' => 'Unrecognized escape \8 in character class {#} m/(?[ \8{#} ])/', '/(?[ \t ]/' => 'Syntax error in (?[...]) in regex m/(?[ \t ]/', '/(?[ [ \t ]/' => 'Syntax error in (?[...]) in regex m/(?[ [ \t ]/', @@ -258,6 +258,9 @@ my @death = 'm/\cß/' => "Character following \"\\c\" must be printable ASCII", '/((?# This is a comment in the middle of a token)?:foo)/' => 'In \'(?...)\', the \'(\' and \'?\' must be adjacent {#} m/((?# This is a comment in the middle of a token)?{#}:foo)/', '/((?# This is a comment in the middle of a token)*FAIL)/' => 'In \'(*VERB...)\', the \'(\' and \'*\' must be adjacent {#} m/((?# This is a comment in the middle of a token)*{#}FAIL)/', + '/(?[\ &!])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[\ &!{#}])/', # [perl #126180] + '/(?[()-!])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[()-!{#}])/', # [perl #126204] + '/(?[!()])/' => 'Incomplete expression within \'(?[ ])\' {#} m/(?[!(){#}])/', # [perl #126404] ); # These are messages that are warnings when not strict; death under 'use re @@ -417,8 +420,8 @@ my @death_utf8 = mark_as_utf8( '/(?[ \o{ネ} ])ネ/' => 'Non-octal character {#} m/(?[ \o{ネ{#}} ])ネ/', '/ネ(?[ \o{} ])ネ/' => 'Number with no digits {#} m/ネ(?[ \o{}{#} ])ネ/', '/(?[ \x{ネ} ])ネ/' => 'Non-hex character {#} m/(?[ \x{ネ{#}} ])ネ/', - '/(?[ \p{ネ} ])/' => 'Property \'ネ\' is unknown {#} m/(?[ \p{ネ}{#} ])/', - '/(?[ \p{ ネ = bar } ])/' => 'Property \'ネ = bar\' is unknown {#} m/(?[ \p{ ネ = bar }{#} ])/', + '/(?[ \p{ネ} ])/' => 'Can\'t find Unicode property definition "ネ" {#} m/(?[ \p{ネ}{#} ])/', + '/(?[ \p{ ネ = bar } ])/' => 'Can\'t find Unicode property definition "ネ = bar" {#} m/(?[ \p{ ネ = bar }{#} ])/', '/ネ(?[ \t ]/' => 'Syntax error in (?[...]) in regex m/ネ(?[ \t ]/', '/(?[ \t + \e # ネ This was supposed to be a comment ])/' => 'Syntax error in (?[...]) in regex m/(?[ \t + \e # ネ This was supposed to be a comment ])/', 'm/(*ネ)ネ/' => q, diff --git a/t/re/regex_sets.t b/t/re/regex_sets.t index ee161b2..a5941ba 100644 --- a/t/re/regex_sets.t +++ b/t/re/regex_sets.t @@ -27,7 +27,6 @@ like("a", qr/(?[ [a] # This is a comment like("a", qr/(?[ [a] # [[:notaclass:]] ])/, 'A comment isn\'t parsed'); unlike(uni_to_native("\x85"), qr/(?[ \t… ])/, 'NEL is white space'); -unlike(uni_to_native("\x85"), qr/(?[ [\t…] ])/, '... including within nested []'); like(uni_to_native("\x85"), qr/(?[ \t + \… ])/, 'can escape NEL to match'); like(uni_to_native("\x85"), qr/(?[ [\…] ])/, '... including within nested []'); like("\t", qr/(?[ \t + \… ])/, 'can do basic union'); @@ -99,6 +98,8 @@ is($@, "", 'qr/(?[ [a] ])/ can be interpolated'); like("B", qr/(?[ [B] | ! ( [^B] ) ])/, "[perl #125892]"); +like("a", qr/(?[ (?#comment) [a]])/, "Can have (?#comments)"); + if (! is_miniperl() && locales_enabled('LC_CTYPE')) { my $utf8_locale = find_utf8_ctype_locale; SKIP: { @@ -138,6 +139,25 @@ if (! is_miniperl() && locales_enabled('LC_CTYPE')) { } } +# RT #126181: \cX behaves strangely inside (?[]) +{ + no warnings qw(syntax regexp); + + eval { $_ = '/(?[(\c]) /'; qr/$_/ }; + like($@, qr/^Syntax error/, '/(?[(\c]) / should not panic'); + eval { $_ = '(?[\c#]' . "\n])"; qr/$_/ }; + like($@, qr/^Syntax error/, '/(?[(\c]) / should not panic'); + eval { $_ = '(?[(\c])'; qr/$_/ }; + like($@, qr/^Syntax error/, '/(?[(\c])/ should be a syntax error'); + eval { $_ = '(?[(\c]) ]\b'; qr/$_/ }; + like($@, qr/^Syntax error/, '/(?[(\c]) ]\b/ should be a syntax error'); + eval { $_ = '(?[\c[]](])'; qr/$_/ }; + like($@, qr/^Syntax error/, '/(?[\c[]](])/ should be a syntax error'); + like("\c#", qr/(?[\c#])/, '\c# should match itself'); + like("\c[", qr/(?[\c[])/, '\c[ should match itself'); + like("\c\ ", qr/(?[\c\])/, '\c\ should match itself'); + like("\c]", qr/(?[\c]])/, '\c] should match itself'); +} done_testing(); diff --git a/t/re/regexp_unicode_prop.t b/t/re/regexp_unicode_prop.t index 8e68ab1..25bb781 100644 --- a/t/re/regexp_unicode_prop.t +++ b/t/re/regexp_unicode_prop.t @@ -240,9 +240,16 @@ sub run_tests { } - my $pat = qr /^Can't find Unicode property definition/; print "# Illegal properties\n"; foreach my $p (@ILLEGAL_PROPERTIES) { + my $pat; + if ($p =~ /::/) { + $pat = qr /^Illegal user-defined property name/; + } + else { + $pat = qr /^Can't find Unicode property definition/; + } + undef $@; my $r = eval "'a' =~ /\\p{$p}/; 1"; is($r, undef, "Unknown Unicode property \\p{$p}"); diff --git a/t/re/subst.t b/t/re/subst.t index 6963c42..f2bf0a2 100644 --- a/t/re/subst.t +++ b/t/re/subst.t @@ -6,9 +6,10 @@ BEGIN { set_up_inc('../lib'); require Config; import Config; require './charset_tools.pl'; + require './loc_tools.pl'; } -plan( tests => 261 ); +plan( tests => 267 ); $_ = 'david'; $a = s/david/rules/r; @@ -1034,9 +1035,27 @@ SKIP: { is("$division$division$division" =~ s/\B/!/ugr, "!$division!$division!$division!", '\\B matches Latin1 before string, mid, and end, /u'); is("\x{2028}\x{2028}\x{2028}" =~ s/\B/!/ugr, "!\x{2028}!\x{2028}!\x{2028}!", '\\B matches above-Latin1 before string, mid, and end, /u'); + fresh_perl_like( '$_=""; /\b{gcb}/; s///g', qr/^$/, {}, + '[perl #126319: Segmentation fault in Perl_sv_catpvn_flags with \b{gcb}' + ); + fresh_perl_like( '$_=""; /\B{gcb}/; s///g', qr/^$/, {}, + '[perl #126319: Segmentation fault in Perl_sv_catpvn_flags with \b{gcb}' + ); + fresh_perl_like( '$_=""; /\b{wb}/; s///g', qr/^$/, {}, + '[perl #126319: Segmentation fault in Perl_sv_catpvn_flags with \b{wb}' + ); + fresh_perl_like( '$_=""; /\B{wb}/; s///g', qr/^$/, {}, + '[perl #126319: Segmentation fault in Perl_sv_catpvn_flags with \b{wb}' + ); + fresh_perl_like( '$_=""; /\b{sb}/; s///g', qr/^$/, {}, + '[perl #126319: Segmentation fault in Perl_sv_catpvn_flags with \b{sb}' + ); + fresh_perl_like( '$_=""; /\B{sb}/; s///g', qr/^$/, {}, + '[perl #126319: Segmentation fault in Perl_sv_catpvn_flags with \b{sb}' + ); + SKIP: { - eval { require POSIX; POSIX->import("locale_h"); }; - if ($@ || !eval { &POSIX::LC_ALL; 1 }) { + if (! locales_enabled('LC_ALL')) { skip "Can't test locale (maybe you are missing POSIX)", 6; } diff --git a/uconfig.h b/uconfig.h index 4fe4d96..127d0a9 100644 --- a/uconfig.h +++ b/uconfig.h @@ -2324,36 +2324,6 @@ * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ -/* HAS_MSG_CTRUNC: - * This symbol, if defined, indicates that the MSG_CTRUNC is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_DONTROUTE: - * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_OOB: - * This symbol, if defined, indicates that the MSG_OOB is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PEEK: - * This symbol, if defined, indicates that the MSG_PEEK is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PROXY: - * This symbol, if defined, indicates that the MSG_PROXY is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_SCM_RIGHTS: - * This symbol, if defined, indicates that the SCM_RIGHTS is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ /* HAS_SOCKADDR_SA_LEN: * This symbol, if defined, indicates that the struct sockaddr * structure has a member called sa_len, indicating the length of @@ -2386,12 +2356,6 @@ /*#define HAS_SOCKET / **/ /*#define HAS_SOCKETPAIR / **/ /*#define HAS_SOCKADDR_SA_LEN / **/ -/*#define HAS_MSG_CTRUNC / **/ -/*#define HAS_MSG_DONTROUTE / **/ -/*#define HAS_MSG_OOB / **/ -/*#define HAS_MSG_PEEK / **/ -/*#define HAS_MSG_PROXY / **/ -/*#define HAS_SCM_RIGHTS / **/ /*#define HAS_SOCKADDR_IN6 / **/ /*#define HAS_SIN6_SCOPE_ID / **/ /*#define HAS_IP_MREQ / **/ @@ -3712,24 +3676,12 @@ */ /*#define HAS_FREXPL / **/ -/* HAS_STRUCT_FS_DATA: - * This symbol, if defined, indicates that the struct fs_data - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_FS_DATA / **/ - /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO / **/ -/* HAS_FSTATFS: - * This symbol, if defined, indicates that the fstatfs routine is - * available to stat filesystems by file descriptors. - */ -/*#define HAS_FSTATFS / **/ - /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to @@ -3767,30 +3719,12 @@ */ /*#define HAS_GETESPWNAM / **/ -/* HAS_GETFSSTAT: - * This symbol, if defined, indicates that the getfsstat routine is - * available to stat filesystems in bulk. - */ -/*#define HAS_GETFSSTAT / **/ - /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ /*#define HAS_GETITIMER / **/ -/* HAS_GETMNT: - * This symbol, if defined, indicates that the getmnt routine is - * available to get filesystem mount info by filename. - */ -/*#define HAS_GETMNT / **/ - -/* HAS_GETMNTENT: - * This symbol, if defined, indicates that the getmntent routine is - * available to iterate through mounted file systems to get their info. - */ -/*#define HAS_GETMNTENT / **/ - /* HAS_GETNAMEINFO: * This symbol, if defined, indicates that the getnameinfo() function * is available for use. @@ -3809,12 +3743,6 @@ */ /*#define HAS_GETSPNAM / **/ -/* HAS_HASMNTOPT: - * This symbol, if defined, indicates that the hasmntopt routine is - * available to query the mount options of file systems. - */ -/*#define HAS_HASMNTOPT / **/ - /* HAS_HYPOT: * This symbol, if defined, indicates that the hypot routine is * available to do the hypotenuse function. @@ -4067,16 +3995,8 @@ * a prototype for the modfl() function. Otherwise, it is up * to the program to supply one. */ -/* HAS_MODFL_POW32_BUG: - * This symbol, if defined, indicates that the modfl routine is - * broken for long doubles >= pow(2, 32). - * For example from 4294967303.150000 one would get 4294967302.000000 - * and 1.150000. The bug has been seen in certain versions of glibc, - * release 2.2.2 is known to be okay. - */ /*#define HAS_MODFL / **/ /*#define HAS_MODFL_PROTO / **/ -/*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is @@ -4332,29 +4252,6 @@ */ /*#define HAS_SETRESUID_PROTO / **/ -/* HAS_STRUCT_STATFS_F_FLAGS: - * This symbol, if defined, indicates that the struct statfs - * does have the f_flags member containing the mount flags of - * the filesystem containing the file. - * This kind of struct statfs is coming from (BSD 4.3), - * not from (SYSV). Older BSDs (like Ultrix) do not - * have statfs() and struct statfs, they have ustat() and getmnt() - * with struct ustat and struct fs_data. - */ -/*#define HAS_STRUCT_STATFS_F_FLAGS / **/ - -/* HAS_STRUCT_STATFS: - * This symbol, if defined, indicates that the struct statfs - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_STATFS / **/ - -/* HAS_FSTATVFS: - * This symbol, if defined, indicates that the fstatvfs routine is - * available to stat filesystems by file descriptors. - */ -/*#define HAS_FSTATVFS / **/ - /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. @@ -4510,12 +4407,6 @@ */ /*#define HAS_USLEEP_PROTO / **/ -/* HAS_USTAT: - * This symbol, if defined, indicates that the ustat system call is - * available to query file system statistics by dev_t. - */ -/*#define HAS_USTAT / **/ - /* HAS_WCSCMP: * This symbol, if defined, indicates that the wcscmp routine is * available to compare two wide character strings. @@ -4652,12 +4543,6 @@ */ /*#define I_MALLOCMALLOC / **/ -/* I_MNTENT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_MNTENT / **/ - /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . @@ -4724,41 +4609,12 @@ */ /*#define I_SYSMODE / **/ -/* I_SYS_MOUNT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_MOUNT / **/ - -/* I_SYS_STATFS: - * This symbol, if defined, indicates that exists. - */ -/*#define I_SYS_STATFS / **/ - -/* I_SYS_STATVFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_STATVFS / **/ - /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUTSNAME / **/ -/* I_SYS_VFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_VFS / **/ - -/* I_USTAT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_USTAT / **/ - /* DOUBLEINFBYTES: * This symbol, if defined, is a comma-separated list of * hexadecimal bytes for the double precision infinity. @@ -5212,6 +5068,6 @@ #endif /* Generated from: - * df2a8dd6f9d81f5ecbb87b94eb107fdf6018b7fe64c1aab4c3ea6c723bbc9374 config_h.SH - * 0ce9d24f6ed83c533882929bc7c0138fe345656c4b7070aad99bb103dbf3790a uconfig.sh + * 5e290cd229e282d7b8c039d4d3271aa6a86f635f8706feb0a5c9607ccf8222b2 config_h.SH + * 60c77ec3349b3452b444d8cf5c04e234a0d5a656b8c10163ee042aaadd992ac2 uconfig.sh * ex: set ro: */ diff --git a/uconfig.sh b/uconfig.sh index bd889e3..97f55a0 100644 --- a/uconfig.sh +++ b/uconfig.sh @@ -160,11 +160,8 @@ d_fpclassl='undef' d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' -d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='undef' -d_fstatfs='undef' -d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='undef' @@ -174,7 +171,6 @@ d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='undef' d_getespwnam='undef' -d_getfsstat='undef' d_getgrent='undef' d_getgrent_r='undef' d_getgrgid_r='undef' @@ -191,8 +187,6 @@ d_gethostprotos='undef' d_getitimer='undef' d_getlogin='undef' d_getlogin_r='undef' -d_getmnt='undef' -d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' @@ -234,7 +228,6 @@ d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' -d_hasmntopt='undef' d_htonl='undef' d_hypot='undef' d_ilogb='undef' @@ -460,10 +453,7 @@ d_sresgproto='undef' d_sresuproto='undef' d_stat='define' d_statblks='undef' -d_statfs_f_flags='undef' -d_statfs_s='undef' d_static_inline='undef' -d_statvfs='undef' d_stdio_cnt_lval='undef' d_stdio_ptr_lval='undef' d_stdio_ptr_lval_nochange_cnt='undef' @@ -522,7 +512,6 @@ d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' -d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' @@ -637,7 +626,6 @@ i_malloc='undef' i_mallocmalloc='undef' i_math='define' i_memory='undef' -i_mntent='undef' i_ndbm='undef' i_netdb='undef' i_neterrno='undef' @@ -668,7 +656,6 @@ i_sysioctl='undef' i_syslog='undef' i_sysmman='undef' i_sysmode='undef' -i_sysmount='undef' i_sysndir='undef' i_sysparam='undef' i_syspoll='undef' @@ -677,8 +664,6 @@ i_syssecrt='undef' i_sysselct='undef' i_syssockio='undef' i_sysstat='define' -i_sysstatfs='undef' -i_sysstatvfs='undef' i_systime='undef' i_systimek='undef' i_systimes='undef' @@ -686,13 +671,11 @@ i_systypes='undef' i_sysuio='undef' i_sysun='undef' i_sysutsname='undef' -i_sysvfs='undef' i_syswait='undef' i_termio='undef' i_termios='undef' i_time='define' i_unistd='undef' -i_ustat='undef' i_utime='undef' i_values='undef' i_varargs='undef' diff --git a/uconfig64.sh b/uconfig64.sh index ec09c1e..57b4cae 100644 --- a/uconfig64.sh +++ b/uconfig64.sh @@ -161,11 +161,8 @@ d_fpclassl='undef' d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' -d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='undef' -d_fstatfs='undef' -d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='undef' @@ -175,7 +172,6 @@ d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='undef' d_getespwnam='undef' -d_getfsstat='undef' d_getgrent='undef' d_getgrent_r='undef' d_getgrgid_r='undef' @@ -192,8 +188,6 @@ d_gethostprotos='undef' d_getitimer='undef' d_getlogin='undef' d_getlogin_r='undef' -d_getmnt='undef' -d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' @@ -235,7 +229,6 @@ d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' -d_hasmntopt='undef' d_htonl='undef' d_hypot='undef' d_ilogb='undef' @@ -461,10 +454,7 @@ d_sresgproto='undef' d_sresuproto='undef' d_stat='define' d_statblks='undef' -d_statfs_f_flags='undef' -d_statfs_s='undef' d_static_inline='undef' -d_statvfs='undef' d_stdio_cnt_lval='undef' d_stdio_ptr_lval='undef' d_stdio_ptr_lval_nochange_cnt='undef' @@ -523,7 +513,6 @@ d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' -d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' @@ -638,7 +627,6 @@ i_malloc='undef' i_mallocmalloc='undef' i_math='define' i_memory='undef' -i_mntent='undef' i_ndbm='undef' i_netdb='undef' i_neterrno='undef' @@ -669,7 +657,6 @@ i_sysioctl='undef' i_syslog='undef' i_sysmman='undef' i_sysmode='undef' -i_sysmount='undef' i_sysndir='undef' i_sysparam='undef' i_syspoll='undef' @@ -678,8 +665,6 @@ i_syssecrt='undef' i_sysselct='undef' i_syssockio='undef' i_sysstat='define' -i_sysstatfs='undef' -i_sysstatvfs='undef' i_systime='undef' i_systimek='undef' i_systimes='undef' @@ -687,13 +672,11 @@ i_systypes='undef' i_sysuio='undef' i_sysun='undef' i_sysutsname='undef' -i_sysvfs='undef' i_syswait='undef' i_termio='undef' i_termios='undef' i_time='define' i_unistd='undef' -i_ustat='undef' i_utime='undef' i_values='undef' i_varargs='undef' diff --git a/utf8.c b/utf8.c index 571c451..86e793b 100644 --- a/utf8.c +++ b/utf8.c @@ -714,7 +714,8 @@ Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) sv = sv_2mortal(Perl_newSVpvf(aTHX_ "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv)); pack_warn = packWARN(WARN_NON_UNICODE); } -#ifndef EBCDIC /* EBCDIC always allows FE, FF */ +#ifndef EBCDIC /* Can never have the equivalent of FE nor FF on EBCDIC, since + not representable in UTF-EBCDIC */ /* The first byte being 0xFE or 0xFF is a subset of the SUPER code * points. We test for these after the regular SUPER ones, and @@ -3845,14 +3846,16 @@ Perl_check_utf8_print(pTHX_ const U8* s, const STRLEN len) STRLEN char_len; if (UTF8_IS_SUPER(s, e)) { if (ckWARN_d(WARN_NON_UNICODE)) { - UV uv = utf8_to_uvchr_buf(s, e, &char_len); - Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE), - "Code point 0x%04"UVXf" is not Unicode, may not be portable", uv); + /* A side effect of this function will be to warn */ + (void) utf8n_to_uvchr(s, e - s, &char_len, UTF8_WARN_SUPER); ok = FALSE; } } else if (UTF8_IS_SURROGATE(s, e)) { if (ckWARN_d(WARN_SURROGATE)) { + /* This has a different warning than the one the called + * function would output, so can't just call it, unlike we + * do for the non-chars and above-unicodes */ UV uv = utf8_to_uvchr_buf(s, e, &char_len); Perl_warner(aTHX_ packWARN(WARN_SURROGATE), "Unicode surrogate U+%04"UVXf" is illegal in UTF-8", uv); @@ -3860,9 +3863,8 @@ Perl_check_utf8_print(pTHX_ const U8* s, const STRLEN len) } } else if ((UTF8_IS_NONCHAR(s, e)) && (ckWARN_d(WARN_NONCHAR))) { - UV uv = utf8_to_uvchr_buf(s, e, &char_len); - Perl_warner(aTHX_ packWARN(WARN_NONCHAR), - "Unicode non-character U+%04"UVXf" is not recommended for open interchange", uv); + /* A side effect of this function will be to warn */ + (void) utf8n_to_uvchr(s, e - s, &char_len, UTF8_WARN_NONCHAR); ok = FALSE; } } diff --git a/util.c b/util.c index 4cae40c..ab468fe 100644 --- a/util.c +++ b/util.c @@ -727,21 +727,37 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) s[rarest], (UV)rarest)); } -/* If SvTAIL(littlestr), it has a fake '\n' at end. */ -/* If SvTAIL is actually due to \Z or \z, this gives false positives - if multiline */ /* =for apidoc fbm_instr Returns the location of the SV in the string delimited by C and -C. It returns C if the string can't be found. The C +C (C) is the char following the last char). +It returns C if the string can't be found. The C does not have to be C, but the search will not be as fast then. =cut + +If SvTAIL(littlestr) is true, a fake "\n" was appended to to the string +during FBM compilation due to FBMcf_TAIL in flags. It indicates that +the littlestr must be anchored to the end of bigstr (or to any \n if +FBMrf_MULTILINE). + +E.g. The regex compiler would compile /abc/ to a littlestr of "abc", +while /abc$/ compiles to "abc\n" with SvTAIL() true. + +A littlestr of "abc", !SvTAIL matches as /abc/; +a littlestr of "ab\n", SvTAIL matches as: + without FBMrf_MULTILINE: /ab\n?\z/ + with FBMrf_MULTILINE: /ab\n/ || /ab\z/; + +(According to Ilya from 1999; I don't know if this is still true, DAPM 2015): + "If SvTAIL is actually due to \Z or \z, this gives false positives + if multiline". */ + char * Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags) { @@ -766,82 +782,103 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U switch (littlelen) { /* Special cases for 0, 1 and 2 */ case 0: return (char*)big; /* Cannot be SvTAIL! */ + case 1: - if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ - /* Know that bigend != big. */ - if (bigend[-1] == '\n') - return (char *)(bigend - 1); - return (char *) bigend; - } - s = big; - while (s < bigend) { - if (*s == *little) - return (char *)s; - s++; - } + if (SvTAIL(littlestr) && !multiline) /* Anchor only! */ + /* [-1] is safe because we know that bigend != big. */ + return (char *) (bigend - (bigend[-1] == '\n')); + + s = (unsigned char *)memchr((void*)big, *little, bigend-big); + if (s) + return (char *)s; if (SvTAIL(littlestr)) return (char *) bigend; return NULL; + case 2: if (SvTAIL(littlestr) && !multiline) { - if (bigend[-1] == '\n' && bigend[-2] == *little) + /* a littlestr with SvTAIL must be of the form "X\n" (where X + * is a single char). It is anchored, and can only match + * "....X\n" or "....X" */ + if (bigend[-2] == *little && bigend[-1] == '\n') return (char*)bigend - 2; if (bigend[-1] == *little) return (char*)bigend - 1; return NULL; } + { - /* This should be better than FBM if c1 == c2, and almost - as good otherwise: maybe better since we do less indirection. - And we save a lot of memory by caching no table. */ - const unsigned char c1 = little[0]; - const unsigned char c2 = little[1]; - - s = big + 1; - bigend--; - if (c1 != c2) { - while (s <= bigend) { - if (s[0] == c2) { - if (s[-1] == c1) - return (char*)s - 1; - s += 2; - continue; - } - next_chars: - if (s[0] == c1) { - if (s == bigend) - goto check_1char_anchor; - if (s[1] == c2) - return (char*)s; - else { - s++; - goto next_chars; - } - } - else - s += 2; - } - goto check_1char_anchor; - } - /* Now c1 == c2 */ - while (s <= bigend) { - if (s[0] == c1) { - if (s[-1] == c1) - return (char*)s - 1; - if (s == bigend) - goto check_1char_anchor; - if (s[1] == c1) - return (char*)s; - s += 3; - } - else - s += 2; - } - } - check_1char_anchor: /* One char and anchor! */ - if (SvTAIL(littlestr) && (*bigend == *little)) - return (char *)bigend; /* bigend is already decremented. */ - return NULL; + /* memchr() is likely to be very fast, possibly using whatever + * hardware support is available, such as checking a whole + * cache line in one instruction. + * So for a 2 char pattern, calling memchr() is likely to be + * faster than running FBM, or rolling our own. The previous + * version of this code was roll-your-own which typically + * only needed to read every 2nd char, which was good back in + * the day, but no longer. + */ + unsigned char c1 = little[0]; + unsigned char c2 = little[1]; + + /* *** for all this case, bigend points to the last char, + * not the trailing \0: this makes the conditions slightly + * simpler */ + bigend--; + s = big; + if (c1 != c2) { + while (s < bigend) { + /* do a quick test for c1 before calling memchr(); + * this avoids the expensive fn call overhead when + * there are lots of c1's */ + if (LIKELY(*s != c1)) { + s++; + s = (unsigned char *)memchr((void*)s, c1, bigend - s); + if (!s) + break; + } + if (s[1] == c2) + return (char*)s; + + /* failed; try searching for c2 this time; that way + * we don't go pathologically slow when the string + * consists mostly of c1's or vice versa. + */ + s += 2; + if (s > bigend) + break; + s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1); + if (!s) + break; + if (s[-1] == c1) + return (char*)s - 1; + } + } + else { + /* c1, c2 the same */ + while (s < bigend) { + if (s[0] == c1) { + got_1char: + if (s[1] == c1) + return (char*)s; + s += 2; + } + else { + s++; + s = (unsigned char *)memchr((void*)s, c1, bigend - s); + if (!s || s >= bigend) + break; + goto got_1char; + } + } + } + + /* failed to find 2 chars; try anchored match at end without + * the \n */ + if (SvTAIL(littlestr) && bigend[0] == little[0]) + return (char *)bigend; + return NULL; + } + default: break; /* Only lengths 0 1 and 2 have special-case code. */ } @@ -861,7 +898,9 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U } return NULL; } + if (!SvVALID(littlestr)) { + /* not compiled; use Perl_ninstr() instead */ char * const b = ninstr((char*)big,(char*)bigend, (char*)little, (char*)little + littlelen); @@ -895,15 +934,30 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U oldlittle = little; if (s < bigend) { const unsigned char * const table = (const unsigned char *) mg->mg_ptr; + const unsigned char lastc = *little; I32 tmp; top2: if ((tmp = table[*s])) { - if ((s += tmp) < bigend) - goto top2; - goto check_end; + /* *s != lastc; earliest position it could match now is + * tmp slots further on */ + if ((s += tmp) >= bigend) + goto check_end; + if (LIKELY(*s != lastc)) { + s++; + s = (unsigned char *)memchr((void*)s, lastc, bigend - s); + if (!s) { + s = bigend; + goto check_end; + } + goto top2; + } } - else { /* less expensive than calling strncmp() */ + + + /* hand-rolled strncmp(): less expensive than calling the + * real function (maybe???) */ + { unsigned char * const olds = s; tmp = littlelen; @@ -930,6 +984,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U } } + /* =for apidoc foldEQ @@ -3255,6 +3310,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) ) { + Stat_t statbuf; if (deftypes) { deftypes = 0; *tmpbuf = '\0'; @@ -3281,13 +3337,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",cur)); - if (PerlLIO_stat(cur,&PL_statbuf) >= 0 - && !S_ISDIR(PL_statbuf.st_mode)) { - dosearch = 0; - scriptname = cur; + { + Stat_t statbuf; + if (PerlLIO_stat(cur,&statbuf) >= 0 + && !S_ISDIR(statbuf.st_mode)) { + dosearch = 0; + scriptname = cur; #ifdef SEARCH_EXTS - break; + break; #endif + } } #ifdef SEARCH_EXTS if (cur == scriptname) { @@ -3313,6 +3372,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, bufend = s + strlen(s); while (s < bufend) { + Stat_t statbuf; # ifdef DOSISH for (len = 0; *s && *s != ';'; len++, s++) { @@ -3349,8 +3409,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, do { #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); - retval = PerlLIO_stat(tmpbuf,&PL_statbuf); - if (S_ISDIR(PL_statbuf.st_mode)) { + retval = PerlLIO_stat(tmpbuf,&statbuf); + if (S_ISDIR(statbuf.st_mode)) { retval = -1; } #ifdef SEARCH_EXTS @@ -3361,10 +3421,10 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, #endif if (retval < 0) continue; - if (S_ISREG(PL_statbuf.st_mode) - && cando(S_IRUSR,TRUE,&PL_statbuf) + if (S_ISREG(statbuf.st_mode) + && cando(S_IRUSR,TRUE,&statbuf) #if !defined(DOSISH) - && cando(S_IXUSR,TRUE,&PL_statbuf) + && cando(S_IXUSR,TRUE,&statbuf) #endif ) { @@ -3375,11 +3435,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, xfailed = savepv(tmpbuf); } #ifndef DOSISH - if (!xfound && !seen_dot && !xfailed && - (PerlLIO_stat(scriptname,&PL_statbuf) < 0 - || S_ISDIR(PL_statbuf.st_mode))) + { + Stat_t statbuf; + if (!xfound && !seen_dot && !xfailed && + (PerlLIO_stat(scriptname,&statbuf) < 0 + || S_ISDIR(statbuf.st_mode))) +#endif + seen_dot = 1; /* Disable message. */ +#ifndef DOSISH + } #endif - seen_dot = 1; /* Disable message. */ if (!xfound) { if (flags & 1) { /* do or die? */ /* diag_listed_as: Can't execute %s */ diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index 701e424..9d43dc8 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -307,7 +307,7 @@ utils : $(utils1) $(utils2) $(utils3) $(utils4) $(utils5) extra.pods : miniperl @ @extra_pods.com -PERLDELTA_CURRENT = [.pod]perl5233delta.pod +PERLDELTA_CURRENT = [.pod]perl5234delta.pod $(PERLDELTA_CURRENT) : [.pod]perldelta.pod Copy/NoConfirm/Log $(MMS$SOURCE) $(PERLDELTA_CURRENT) diff --git a/vms/vms.c b/vms/vms.c index d415413..fb29dd5 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -42,6 +42,7 @@ #include #include #include +#include #include #include #include @@ -2174,7 +2175,6 @@ Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act, } /*}}}*/ -#ifdef KILL_BY_SIGPRC #include /* We implement our own kill() using the undocumented system service @@ -2272,6 +2272,7 @@ Perl_sig_to_vmscondition(int sig) } +#ifdef KILL_BY_SIGPRC #define sys$sigprc SYS$SIGPRC #ifdef __cplusplus extern "C" { @@ -2321,17 +2322,18 @@ Perl_my_kill(int pid, int sig) return -1; } - /* Fixme: Per official UNIX specification: If pid = 0, or negative then + /* Per official UNIX specification: If pid = 0, or negative then * signals are to be sent to multiple processes. * pid = 0 - all processes in group except ones that the system exempts * pid = -1 - all processes except ones that the system exempts * pid = -n - all processes in group (abs(n)) except ... - * For now, just report as not supported. + * + * Handle these via killpg, which is redundant for the -n case, since OP_KILL + * in doio.c already does that. killpg currently does not support the -1 case. */ if (pid <= 0) { - SETERRNO(ENOTSUP, SS$_UNSUPPORTED); - return -1; + return killpg(-pid, sig); } iss = sys$sigprc((unsigned int *)&pid,0,code); @@ -2356,6 +2358,157 @@ Perl_my_kill(int pid, int sig) } #endif +int +Perl_my_killpg(pid_t master_pid, int signum) +{ + int pid, status, i; + unsigned long int jpi_context; + unsigned short int iosb[4]; + struct itmlst_3 il3[3]; + + /* All processes on the system? Seems dangerous, but it looks + * like we could implement this pretty easily with a wildcard + * input to sys$process_scan. + */ + if (master_pid == -1) { + SETERRNO(ENOTSUP, SS$_UNSUPPORTED); + return -1; + } + + /* All processes in the current process group; find the master + * pid for the current process. + */ + if (master_pid == 0) { + i = 0; + il3[i].buflen = sizeof( int ); + il3[i].itmcode = JPI$_MASTER_PID; + il3[i].bufadr = &master_pid; + il3[i++].retlen = NULL; + + il3[i].buflen = 0; + il3[i].itmcode = 0; + il3[i].bufadr = NULL; + il3[i++].retlen = NULL; + + status = sys$getjpiw(EFN$C_ENF, NULL, NULL, il3, iosb, NULL, 0); + if ($VMS_STATUS_SUCCESS(status)) + status = iosb[0]; + + switch (status) { + case SS$_NORMAL: + break; + case SS$_NOPRIV: + case SS$_SUSPENDED: + SETERRNO(EPERM, status); + break; + case SS$_NOMOREPROC: + case SS$_NONEXPR: + case SS$_NOSUCHNODE: + case SS$_UNREACHABLE: + SETERRNO(ESRCH, status); + break; + case SS$_ACCVIO: + case SS$_BADPARAM: + SETERRNO(EINVAL, status); + break; + default: + SETERRNO(EVMSERR, status); + } + if (!$VMS_STATUS_SUCCESS(status)) + return -1; + } + + /* Set up a process context for those processes we will scan + * with sys$getjpiw. Ask for all processes belonging to the + * master pid. + */ + + i = 0; + il3[i].buflen = 0; + il3[i].itmcode = PSCAN$_MASTER_PID; + il3[i].bufadr = (void *)master_pid; + il3[i++].retlen = NULL; + + il3[i].buflen = 0; + il3[i].itmcode = 0; + il3[i].bufadr = NULL; + il3[i++].retlen = NULL; + + status = sys$process_scan(&jpi_context, il3); + switch (status) { + case SS$_NORMAL: + break; + case SS$_ACCVIO: + case SS$_BADPARAM: + case SS$_IVBUFLEN: + case SS$_IVSSRQ: + SETERRNO(EINVAL, status); + break; + default: + SETERRNO(EVMSERR, status); + } + if (!$VMS_STATUS_SUCCESS(status)) + return -1; + + i = 0; + il3[i].buflen = sizeof(int); + il3[i].itmcode = JPI$_PID; + il3[i].bufadr = &pid; + il3[i++].retlen = NULL; + + il3[i].buflen = 0; + il3[i].itmcode = 0; + il3[i].bufadr = NULL; + il3[i++].retlen = NULL; + + /* Loop through the processes matching our specified criteria + */ + + while (1) { + /* Find the next process... + */ + status = sys$getjpiw( EFN$C_ENF, &jpi_context, NULL, il3, iosb, NULL, 0); + if ($VMS_STATUS_SUCCESS(status)) status = iosb[0]; + + switch (status) { + case SS$_NORMAL: + if (kill(pid, signum) == -1) + break; + + continue; /* next process */ + case SS$_NOPRIV: + case SS$_SUSPENDED: + SETERRNO(EPERM, status); + break; + case SS$_NOMOREPROC: + break; + case SS$_NONEXPR: + case SS$_NOSUCHNODE: + case SS$_UNREACHABLE: + SETERRNO(ESRCH, status); + break; + case SS$_ACCVIO: + case SS$_BADPARAM: + SETERRNO(EINVAL, status); + break; + default: + SETERRNO(EVMSERR, status); + } + + if (!$VMS_STATUS_SUCCESS(status)) + break; + } + + /* Release context-related resources. + */ + (void) sys$process_scan(&jpi_context); + + if (status != SS$_NOMOREPROC) + return -1; + + return 0; +} + /* Routine to convert a VMS status code to a UNIX status code. ** More tricky than it appears because of conflicting conventions with ** existing code. diff --git a/vms/vmsish.h b/vms/vmsish.h index d175b18..407fe6d 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -477,6 +477,7 @@ struct utimbuf { #ifdef KILL_BY_SIGPRC # define kill Perl_my_kill #endif +# define killpg Perl_my_killpg /* VMS doesn't use a real sys_nerr, but we need this when scanning for error @@ -714,6 +715,7 @@ int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*); #ifdef KILL_BY_SIGPRC unsigned int Perl_sig_to_vmscondition (int); int Perl_my_kill (int, int); +int Perl_my_killpg (int, int); void Perl_csighandler_init (void); #endif int Perl_my_utime (pTHX_ const char *, const struct utimbuf *); diff --git a/warnings.h b/warnings.h index 4e91ae6..4ab2d1d 100644 --- a/warnings.h +++ b/warnings.h @@ -91,26 +91,25 @@ #define WARN_EXPERIMENTAL 51 #define WARN_EXPERIMENTAL__LEXICAL_SUBS 52 -#define WARN_EXPERIMENTAL__LEXICAL_TOPIC 53 -#define WARN_EXPERIMENTAL__REGEX_SETS 54 -#define WARN_EXPERIMENTAL__SMARTMATCH 55 +#define WARN_EXPERIMENTAL__REGEX_SETS 53 +#define WARN_EXPERIMENTAL__SMARTMATCH 54 /* Warnings Categories added in Perl 5.019 */ -#define WARN_EXPERIMENTAL__POSTDEREF 56 -#define WARN_EXPERIMENTAL__SIGNATURES 57 -#define WARN_SYSCALLS 58 +#define WARN_EXPERIMENTAL__POSTDEREF 55 +#define WARN_EXPERIMENTAL__SIGNATURES 56 +#define WARN_SYSCALLS 57 /* Warnings Categories added in Perl 5.021 */ -#define WARN_EXPERIMENTAL__BITWISE 59 -#define WARN_EXPERIMENTAL__CONST_ATTR 60 -#define WARN_EXPERIMENTAL__RE_STRICT 61 -#define WARN_EXPERIMENTAL__REFALIASING 62 -#define WARN_EXPERIMENTAL__WIN32_PERLIO 63 -#define WARN_LOCALE 64 -#define WARN_MISSING 65 -#define WARN_REDUNDANT 66 +#define WARN_EXPERIMENTAL__BITWISE 58 +#define WARN_EXPERIMENTAL__CONST_ATTR 59 +#define WARN_EXPERIMENTAL__RE_STRICT 60 +#define WARN_EXPERIMENTAL__REFALIASING 61 +#define WARN_EXPERIMENTAL__WIN32_PERLIO 62 +#define WARN_LOCALE 63 +#define WARN_MISSING 64 +#define WARN_REDUNDANT 65 #define WARNsize 17 #define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125" diff --git a/win32/GNUmakefile b/win32/GNUmakefile index 651ffc6..6360456 100644 --- a/win32/GNUmakefile +++ b/win32/GNUmakefile @@ -66,7 +66,7 @@ INST_TOP := $(INST_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -#INST_VER := \5.23.3 +#INST_VER := \5.23.4 # # Comment this out if you DON'T want your perl installation to have @@ -1130,7 +1130,7 @@ utils: $(PERLEXE) ..\utils\Makefile copy ..\README.tw ..\pod\perltw.pod copy ..\README.vos ..\pod\perlvos.pod copy ..\README.win32 ..\pod\perlwin32.pod - copy ..\pod\perldelta.pod ..\pod\perl5233delta.pod + copy ..\pod\perldelta.pod ..\pod\perl5234delta.pod $(PERLEXE) $(PL2BAT) $(UTILS) $(MINIPERL) -I..\lib ..\autodoc.pl .. $(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q .. @@ -1225,7 +1225,7 @@ distclean: realclean -if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API -if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS -cd $(PODDIR) && del /f *.html *.bat roffitall \ - perl5233delta.pod perlaix.pod perlamiga.pod perlandroid.pod \ + perl5234delta.pod perlaix.pod perlamiga.pod perlandroid.pod \ perlapi.pod perlbs2000.pod perlce.pod perlcn.pod perlcygwin.pod \ perldos.pod perlfreebsd.pod perlhaiku.pod perlhpux.pod \ perlhurd.pod perlintern.pod perlirix.pod perljp.pod perlko.pod \ diff --git a/win32/Makefile b/win32/Makefile index f6d8fb5..787d888 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -38,7 +38,7 @@ INST_TOP = $(INST_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -#INST_VER = \5.23.3 +#INST_VER = \5.23.4 # # Comment this out if you DON'T want your perl installation to have @@ -96,6 +96,13 @@ USE_LARGE_FILES = define #USE_64_BIT_INT = define # +# Uncomment this if you want to disable looking up values from +# HKEY_CURRENT_USER\Software\Perl and HKEY_LOCAL_MACHINE\Software\Perl in +# the Registry. +# +#USE_NO_REGISTRY = define + +# # uncomment exactly one of the following # # Visual C++ 6.0 (aka Visual C++ 98) @@ -294,6 +301,10 @@ USE_LARGE_FILES = undef USE_64_BIT_INT = undef !ENDIF +!IF "$(USE_NO_REGISTRY)" == "" +USE_NO_REGISTRY = undef +!ENDIF + !IF "$(USE_IMP_SYS)$(USE_MULTI)" == "defineundef" USE_MULTI = define !ENDIF @@ -314,6 +325,10 @@ BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_CONTEXT BUILDOPT = $(BUILDOPT) -DPERL_IMPLICIT_SYS !ENDIF +!IF "$(USE_NO_REGISTRY)" != "undef" +BUILDOPT = $(BUILDOPT) -DWIN32_NO_REGISTRY +!ENDIF + !IF "$(PROCESSOR_ARCHITECTURE)" == "" PROCESSOR_ARCHITECTURE = x86 !ENDIF @@ -388,7 +403,16 @@ ARCHNAME = $(ARCHNAME)-64int # All but the free version of VC++ 7.1 can load DLLs on demand. Makes the test # suite run in about 10% less time. !IF "$(CCTYPE)" != "MSVC70FREE" +# If no registry, advapi32 is only used for Perl_pp_getlogin/getlogin/GetUserNameA +# which is rare to execute +!IF "$(USE_NO_REGISTRY)" != "undef" +DELAYLOAD = -DELAYLOAD:ws2_32.dll -DELAYLOAD:advapi32.dll delayimp.lib +MINIDELAYLOAD = +!ELSE DELAYLOAD = -DELAYLOAD:ws2_32.dll delayimp.lib +#miniperl never does any registry lookups +MINIDELAYLOAD = -DELAYLOAD:advapi32.dll +!ENDIF !ENDIF # Visual C++ 2005 and 2008 (VC++ 8.0 and 9.0) create manifest files for EXEs and @@ -1023,7 +1047,7 @@ $(MINIPERL) : ..\lib\buildcustomize.pl ..\lib\buildcustomize.pl : $(MINIDIR) $(MINI_OBJ) ..\write_buildcustomize.pl $(LINK32) -out:$(MINIPERL) @<< - $(BLINK_FLAGS) $(DELAYLOAD) $(LIBFILES) $(MINI_OBJ) + $(BLINK_FLAGS) $(DELAYLOAD) $(MINIDELAYLOAD) $(LIBFILES) $(MINI_OBJ) << $(EMBED_EXE_MANI:..\lib\buildcustomize.pl=..\miniperl.exe) $(MINIPERL) -I..\lib -f ..\write_buildcustomize.pl .. @@ -1195,7 +1219,7 @@ utils: $(PERLEXE) ..\utils\Makefile copy ..\README.tw ..\pod\perltw.pod copy ..\README.vos ..\pod\perlvos.pod copy ..\README.win32 ..\pod\perlwin32.pod - copy ..\pod\perldelta.pod ..\pod\perl5233delta.pod + copy ..\pod\perldelta.pod ..\pod\perl5234delta.pod cd ..\win32 $(PERLEXE) $(PL2BAT) $(UTILS) $(MINIPERL) -I..\lib ..\autodoc.pl .. @@ -1292,7 +1316,7 @@ distclean: realclean -if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API -if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS -cd $(PODDIR) && del /f *.html *.bat roffitall \ - perl5233delta.pod perlaix.pod perlamiga.pod perlandroid.pod \ + perl5234delta.pod perlaix.pod perlamiga.pod perlandroid.pod \ perlapi.pod perlbs2000.pod perlce.pod perlcn.pod perlcygwin.pod \ perldos.pod perlfreebsd.pod perlhaiku.pod perlhpux.pod \ perlhurd.pod perlintern.pod perlirix.pod perljp.pod perlko.pod \ diff --git a/win32/config.ce b/win32/config.ce index 3c10d77..c3f1e49 100644 --- a/win32/config.ce +++ b/win32/config.ce @@ -208,11 +208,8 @@ d_fpclassl='undef' d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' -d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='define' -d_fstatfs='undef' -d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='define' @@ -222,7 +219,6 @@ d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' d_getespwnam='undef' -d_getfsstat='undef' d_getgrent='undef' d_getgrent_r='undef' d_getgrgid_r='undef' @@ -239,8 +235,6 @@ d_gethostprotos='define' d_getitimer='undef' d_getlogin='define' d_getlogin_r='undef' -d_getmnt='undef' -d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' @@ -282,7 +276,6 @@ d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' -d_hasmntopt='undef' d_htonl='define' d_hypot='undef' d_ilogb='undef' @@ -509,10 +502,7 @@ d_sresgproto='undef' d_sresuproto='undef' d_stat='define' d_statblks='undef' -d_statfs_f_flags='undef' -d_statfs_s='undef' d_static_inline='undef' -d_statvfs='undef' d_stdio_cnt_lval='undef' d_stdio_ptr_lval='undef' d_stdio_ptr_lval_nochange_cnt='undef' @@ -571,7 +561,6 @@ d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' -d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' @@ -708,7 +697,6 @@ i_malloc='define' i_mallocmalloc='undef' i_math='define' i_memory='undef' -i_mntent='undef' i_ndbm='undef' i_netdb='undef' i_neterrno='undef' @@ -739,7 +727,6 @@ i_sysioctl='undef' i_syslog='undef' i_sysmman='undef' i_sysmode='undef' -i_sysmount='undef' i_sysndir='undef' i_sysparam='undef' i_syspoll='undef' @@ -748,8 +735,6 @@ i_syssecrt='undef' i_sysselct='undef' i_syssockio='undef' i_sysstat='define' -i_sysstatfs='undef' -i_sysstatvfs='undef' i_systime='undef' i_systimek='undef' i_systimes='undef' @@ -757,13 +742,11 @@ i_systypes='undef' i_sysuio='undef' i_sysun='undef' i_sysutsname='undef' -i_sysvfs='undef' i_syswait='undef' i_termio='undef' i_termios='undef' i_time='undef' i_unistd='undef' -i_ustat='undef' i_utime='define' i_values='undef' i_varargs='undef' diff --git a/win32/config.gc b/win32/config.gc index e0eb238..ac7d288 100644 --- a/win32/config.gc +++ b/win32/config.gc @@ -209,11 +209,8 @@ d_fpclassl='undef' d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' -d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='define' -d_fstatfs='undef' -d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='define' @@ -223,7 +220,6 @@ d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' d_getespwnam='undef' -d_getfsstat='undef' d_getgrent='undef' d_getgrent_r='undef' d_getgrgid_r='undef' @@ -240,8 +236,6 @@ d_gethostprotos='define' d_getitimer='undef' d_getlogin='define' d_getlogin_r='undef' -d_getmnt='undef' -d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' @@ -282,7 +276,6 @@ d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' -d_hasmntopt='undef' d_htonl='define' d_hypot='undef' d_ilogb='undef' @@ -509,10 +502,7 @@ d_sresgproto='undef' d_sresuproto='undef' d_stat='define' d_statblks='undef' -d_statfs_f_flags='undef' -d_statfs_s='undef' d_static_inline='define' -d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' d_stdio_ptr_lval_nochange_cnt='define' @@ -571,7 +561,6 @@ d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' -d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' @@ -720,7 +709,6 @@ i_malloc='define' i_mallocmalloc='undef' i_math='define' i_memory='undef' -i_mntent='undef' i_ndbm='undef' i_netdb='undef' i_neterrno='undef' @@ -751,7 +739,6 @@ i_sysioctl='undef' i_syslog='undef' i_sysmman='undef' i_sysmode='undef' -i_sysmount='undef' i_sysndir='undef' i_sysparam='undef' i_syspoll='undef' @@ -760,8 +747,6 @@ i_syssecrt='undef' i_sysselct='undef' i_syssockio='undef' i_sysstat='define' -i_sysstatfs='undef' -i_sysstatvfs='undef' i_systime='undef' i_systimek='undef' i_systimes='undef' @@ -769,13 +754,11 @@ i_systypes='define' i_sysuio='undef' i_sysun='undef' i_sysutsname='undef' -i_sysvfs='undef' i_syswait='undef' i_termio='undef' i_termios='undef' i_time='define' i_unistd='undef' -i_ustat='undef' i_utime='define' i_values='undef' i_varargs='undef' diff --git a/win32/config.vc b/win32/config.vc index b4efd32..2a44a06 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -209,11 +209,8 @@ d_fpclassl='undef' d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' -d_fs_data_s='undef' d_fseeko='undef' d_fsetpos='define' -d_fstatfs='undef' -d_fstatvfs='undef' d_fsync='undef' d_ftello='undef' d_ftime='define' @@ -223,7 +220,6 @@ d_gdbmndbm_h_uses_prototypes='undef' d_getaddrinfo='undef' d_getcwd='define' d_getespwnam='undef' -d_getfsstat='undef' d_getgrent='undef' d_getgrent_r='undef' d_getgrgid_r='undef' @@ -240,8 +236,6 @@ d_gethostprotos='define' d_getitimer='undef' d_getlogin='define' d_getlogin_r='undef' -d_getmnt='undef' -d_getmntent='undef' d_getnameinfo='undef' d_getnbyaddr='undef' d_getnbyname='undef' @@ -282,7 +276,6 @@ d_gmtime64='undef' d_gmtime_r='undef' d_gnulibc='undef' d_grpasswd='undef' -d_hasmntopt='undef' d_htonl='define' d_hypot='undef' d_ilogb='undef' @@ -509,10 +502,7 @@ d_sresgproto='undef' d_sresuproto='undef' d_stat='define' d_statblks='undef' -d_statfs_f_flags='undef' -d_statfs_s='undef' d_static_inline='define' -d_statvfs='undef' d_stdio_cnt_lval='define' d_stdio_ptr_lval='define' d_stdio_ptr_lval_nochange_cnt='define' @@ -571,7 +561,6 @@ d_unordered='undef' d_unsetenv='undef' d_usleep='undef' d_usleepproto='undef' -d_ustat='undef' d_vendorarch='undef' d_vendorbin='undef' d_vendorlib='undef' @@ -719,7 +708,6 @@ i_malloc='define' i_mallocmalloc='undef' i_math='define' i_memory='undef' -i_mntent='undef' i_ndbm='undef' i_netdb='undef' i_neterrno='undef' @@ -750,7 +738,6 @@ i_sysioctl='undef' i_syslog='undef' i_sysmman='undef' i_sysmode='undef' -i_sysmount='undef' i_sysndir='undef' i_sysparam='undef' i_syspoll='undef' @@ -759,8 +746,6 @@ i_syssecrt='undef' i_sysselct='undef' i_syssockio='undef' i_sysstat='define' -i_sysstatfs='undef' -i_sysstatvfs='undef' i_systime='undef' i_systimek='undef' i_systimes='undef' @@ -768,13 +753,11 @@ i_systypes='define' i_sysuio='undef' i_sysun='undef' i_sysutsname='undef' -i_sysvfs='undef' i_syswait='undef' i_termio='undef' i_termios='undef' i_time='define' i_unistd='undef' -i_ustat='undef' i_utime='define' i_values='undef' i_varargs='undef' diff --git a/win32/config_H.ce b/win32/config_H.ce index 1766a95..13f28b2 100644 --- a/win32/config_H.ce +++ b/win32/config_H.ce @@ -1409,24 +1409,12 @@ */ /*#define HAS_FREXPL /**/ -/* HAS_STRUCT_FS_DATA: - * This symbol, if defined, indicates that the struct fs_data - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_FS_DATA /**/ - /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO /**/ -/* HAS_FSTATFS: - * This symbol, if defined, indicates that the fstatfs routine is - * available to stat filesystems by file descriptors. - */ -/*#define HAS_FSTATFS /**/ - /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to @@ -1475,12 +1463,6 @@ */ /*#define HAS_GETESPWNAM /**/ -/* HAS_GETFSSTAT: - * This symbol, if defined, indicates that the getfsstat routine is - * available to stat filesystems in bulk. - */ -/*#define HAS_GETFSSTAT /**/ - /* HAS_GETGRENT: * This symbol, if defined, indicates that the getgrent routine is * available for sequential access of the group database. @@ -1600,18 +1582,6 @@ /*#define HAS_GETLOGIN_R /**/ #define GETLOGIN_R_PROTO 0 /**/ -/* HAS_GETMNT: - * This symbol, if defined, indicates that the getmnt routine is - * available to get filesystem mount info by filename. - */ -/*#define HAS_GETMNT /**/ - -/* HAS_GETMNTENT: - * This symbol, if defined, indicates that the getmntent routine is - * available to iterate through mounted file systems to get their info. - */ -/*#define HAS_GETMNTENT /**/ - /* HAS_GETNETBYADDR: * This symbol, if defined, indicates that the getnetbyaddr() routine is * available to look up networks by their IP addresses. @@ -1799,11 +1769,6 @@ #if defined(HAS_GNULIBC) && !defined(_GNU_SOURCE) # define _GNU_SOURCE #endif -/* HAS_HASMNTOPT: - * This symbol, if defined, indicates that the hasmntopt routine is - * available to query the mount options of file systems. - */ -/*#define HAS_HASMNTOPT /**/ /* HAS_HTONL: * This symbol, if defined, indicates that the htonl() routine (and @@ -2009,16 +1974,8 @@ * a prototype for the modfl() function. Otherwise, it is up * to the program to supply one. */ -/* HAS_MODFL_POW32_BUG: - * This symbol, if defined, indicates that the modfl routine is - * broken for long doubles >= pow(2, 32). - * For example from 4294967303.150000 one would get 4294967302.000000 - * and 1.150000. The bug has been seen in certain versions of glibc, - * release 2.2.2 is known to be okay. - */ /*#define HAS_MODFL /**/ /*#define HAS_MODFL_PROTO /**/ -/*#define HAS_MODFL_POW32_BUG /**/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is @@ -2339,44 +2296,8 @@ * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ -/* HAS_MSG_CTRUNC: - * This symbol, if defined, indicates that the MSG_CTRUNC is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_DONTROUTE: - * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_OOB: - * This symbol, if defined, indicates that the MSG_OOB is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PEEK: - * This symbol, if defined, indicates that the MSG_PEEK is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PROXY: - * This symbol, if defined, indicates that the MSG_PROXY is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_SCM_RIGHTS: - * This symbol, if defined, indicates that the SCM_RIGHTS is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ #define HAS_SOCKET /**/ /*#define HAS_SOCKETPAIR /**/ -/*#define HAS_MSG_CTRUNC /**/ -/*#define HAS_MSG_DONTROUTE /**/ -/*#define HAS_MSG_OOB /**/ -/*#define HAS_MSG_PEEK /**/ -/*#define HAS_MSG_PROXY /**/ -/*#define HAS_SCM_RIGHTS /**/ /* HAS_SOCKS5_INIT: * This symbol, if defined, indicates that the socks5_init routine is @@ -2424,29 +2345,6 @@ /*#define USE_STAT_BLOCKS /**/ #endif -/* HAS_STRUCT_STATFS_F_FLAGS: - * This symbol, if defined, indicates that the struct statfs - * does have the f_flags member containing the mount flags of - * the filesystem containing the file. - * This kind of struct statfs is coming from (BSD 4.3), - * not from (SYSV). Older BSDs (like Ultrix) do not - * have statfs() and struct statfs, they have ustat() and getmnt() - * with struct ustat and struct fs_data. - */ -/*#define HAS_STRUCT_STATFS_F_FLAGS /**/ - -/* HAS_STRUCT_STATFS: - * This symbol, if defined, indicates that the struct statfs - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_STATFS /**/ - -/* HAS_FSTATVFS: - * This symbol, if defined, indicates that the fstatvfs routine is - * available to stat filesystems by file descriptors. - */ -/*#define HAS_FSTATVFS /**/ - /* USE_STDIO_PTR: * This symbol is defined if the _ptr and _cnt fields (or similar) * of the stdio FILE structure can be used to access the stdio buffer @@ -2665,12 +2563,6 @@ */ /*#define HAS_UNSETENV /**/ -/* HAS_USTAT: - * This symbol, if defined, indicates that the ustat system call is - * available to query file system statistics by dev_t. - */ -/*#define HAS_USTAT /**/ - /* HAS_VFORK: * This symbol, if defined, indicates that vfork() exists. */ @@ -2892,12 +2784,6 @@ */ /*#define I_MACH_CTHREADS /**/ -/* I_MNTENT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_MNTENT /**/ - /* I_NETDB: * This symbol, if defined, indicates that exists and * should be included. @@ -3004,23 +2890,6 @@ */ /*#define I_SYSMODE /**/ -/* I_SYS_MOUNT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_MOUNT /**/ - -/* I_SYS_STATFS: - * This symbol, if defined, indicates that exists. - */ -/*#define I_SYS_STATFS /**/ - -/* I_SYS_STATVFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_STATVFS /**/ - /* I_SYSUIO: * This symbol, if defined, indicates that exists and * should be included. @@ -3033,12 +2902,6 @@ */ /*#define I_SYSUTSNAME /**/ -/* I_SYS_VFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_VFS /**/ - /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . @@ -3065,12 +2928,6 @@ /*#define HAS_TM_TM_ZONE /**/ /*#define HAS_TM_TM_GMTOFF /**/ -/* I_USTAT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_USTAT /**/ - /* PERL_INC_VERSION_LIST: * This variable specifies the list of subdirectories in over * which perl.c:incpush() and lib/lib.pm will automatically diff --git a/win32/config_H.gc b/win32/config_H.gc index a9c6162..41d8395 100644 --- a/win32/config_H.gc +++ b/win32/config_H.gc @@ -2312,36 +2312,6 @@ * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ -/* HAS_MSG_CTRUNC: - * This symbol, if defined, indicates that the MSG_CTRUNC is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_DONTROUTE: - * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_OOB: - * This symbol, if defined, indicates that the MSG_OOB is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PEEK: - * This symbol, if defined, indicates that the MSG_PEEK is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PROXY: - * This symbol, if defined, indicates that the MSG_PROXY is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_SCM_RIGHTS: - * This symbol, if defined, indicates that the SCM_RIGHTS is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ /* HAS_SOCKADDR_SA_LEN: * This symbol, if defined, indicates that the struct sockaddr * structure has a member called sa_len, indicating the length of @@ -2374,12 +2344,6 @@ #define HAS_SOCKET /**/ /*#define HAS_SOCKETPAIR / **/ /*#define HAS_SOCKADDR_SA_LEN / **/ -/*#define HAS_MSG_CTRUNC / **/ -/*#define HAS_MSG_DONTROUTE / **/ -/*#define HAS_MSG_OOB / **/ -/*#define HAS_MSG_PEEK / **/ -/*#define HAS_MSG_PROXY / **/ -/*#define HAS_SCM_RIGHTS / **/ /*#define HAS_SOCKADDR_IN6 / **/ #define HAS_SIN6_SCOPE_ID /**/ /*#define HAS_IP_MREQ / **/ @@ -3674,24 +3638,12 @@ */ /*#define HAS_FREXPL / **/ -/* HAS_STRUCT_FS_DATA: - * This symbol, if defined, indicates that the struct fs_data - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_FS_DATA / **/ - /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO / **/ -/* HAS_FSTATFS: - * This symbol, if defined, indicates that the fstatfs routine is - * available to stat filesystems by file descriptors. - */ -/*#define HAS_FSTATFS / **/ - /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to @@ -3729,30 +3681,12 @@ */ /*#define HAS_GETESPWNAM / **/ -/* HAS_GETFSSTAT: - * This symbol, if defined, indicates that the getfsstat routine is - * available to stat filesystems in bulk. - */ -/*#define HAS_GETFSSTAT / **/ - /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ /*#define HAS_GETITIMER / **/ -/* HAS_GETMNT: - * This symbol, if defined, indicates that the getmnt routine is - * available to get filesystem mount info by filename. - */ -/*#define HAS_GETMNT / **/ - -/* HAS_GETMNTENT: - * This symbol, if defined, indicates that the getmntent routine is - * available to iterate through mounted file systems to get their info. - */ -/*#define HAS_GETMNTENT / **/ - /* HAS_GETNAMEINFO: * This symbol, if defined, indicates that the getnameinfo() function * is available for use. @@ -3771,12 +3705,6 @@ */ /*#define HAS_GETSPNAM / **/ -/* HAS_HASMNTOPT: - * This symbol, if defined, indicates that the hasmntopt routine is - * available to query the mount options of file systems. - */ -/*#define HAS_HASMNTOPT / **/ - /* HAS_ILOGBL: * This symbol, if defined, indicates that the ilogbl routine is * available. If scalbnl is also present we can emulate frexpl. @@ -3913,16 +3841,8 @@ * a prototype for the modfl() function. Otherwise, it is up * to the program to supply one. */ -/* HAS_MODFL_POW32_BUG: - * This symbol, if defined, indicates that the modfl routine is - * broken for long doubles >= pow(2, 32). - * For example from 4294967303.150000 one would get 4294967302.000000 - * and 1.150000. The bug has been seen in certain versions of glibc, - * release 2.2.2 is known to be okay. - */ /*#define HAS_MODFL / **/ /*#define HAS_MODFL_PROTO / **/ -/*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is @@ -4117,29 +4037,6 @@ */ /*#define HAS_SETRESUID_PROTO / **/ -/* HAS_STRUCT_STATFS_F_FLAGS: - * This symbol, if defined, indicates that the struct statfs - * does have the f_flags member containing the mount flags of - * the filesystem containing the file. - * This kind of struct statfs is coming from (BSD 4.3), - * not from (SYSV). Older BSDs (like Ultrix) do not - * have statfs() and struct statfs, they have ustat() and getmnt() - * with struct ustat and struct fs_data. - */ -/*#define HAS_STRUCT_STATFS_F_FLAGS / **/ - -/* HAS_STRUCT_STATFS: - * This symbol, if defined, indicates that the struct statfs - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_STATFS / **/ - -/* HAS_FSTATVFS: - * This symbol, if defined, indicates that the fstatvfs routine is - * available to stat filesystems by file descriptors. - */ -/*#define HAS_FSTATVFS / **/ - /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. @@ -4283,12 +4180,6 @@ */ /*#define HAS_USLEEP_PROTO / **/ -/* HAS_USTAT: - * This symbol, if defined, indicates that the ustat system call is - * available to query file system statistics by dev_t. - */ -/*#define HAS_USTAT / **/ - /* HAS_WCSCMP: * This symbol, if defined, indicates that the wcscmp routine is * available to compare two wide character strings. @@ -4425,12 +4316,6 @@ */ /*#define I_MALLOCMALLOC / **/ -/* I_MNTENT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_MNTENT / **/ - /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . @@ -4491,41 +4376,12 @@ */ /*#define I_SYSMODE / **/ -/* I_SYS_MOUNT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_MOUNT / **/ - -/* I_SYS_STATFS: - * This symbol, if defined, indicates that exists. - */ -/*#define I_SYS_STATFS / **/ - -/* I_SYS_STATVFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_STATVFS / **/ - /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUTSNAME / **/ -/* I_SYS_VFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_VFS / **/ - -/* I_USTAT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_USTAT / **/ - /* PERL_PRIfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for output. diff --git a/win32/config_H.vc b/win32/config_H.vc index e945b3f..7a76f1d 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -2304,36 +2304,6 @@ * This symbol, if defined, indicates that the BSD socketpair() call is * supported. */ -/* HAS_MSG_CTRUNC: - * This symbol, if defined, indicates that the MSG_CTRUNC is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_DONTROUTE: - * This symbol, if defined, indicates that the MSG_DONTROUTE is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_OOB: - * This symbol, if defined, indicates that the MSG_OOB is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PEEK: - * This symbol, if defined, indicates that the MSG_PEEK is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_MSG_PROXY: - * This symbol, if defined, indicates that the MSG_PROXY is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ -/* HAS_SCM_RIGHTS: - * This symbol, if defined, indicates that the SCM_RIGHTS is supported. - * Checking just with #ifdef might not be enough because this symbol - * has been known to be an enum. - */ /* HAS_SOCKADDR_SA_LEN: * This symbol, if defined, indicates that the struct sockaddr * structure has a member called sa_len, indicating the length of @@ -2366,12 +2336,6 @@ #define HAS_SOCKET /**/ /*#define HAS_SOCKETPAIR / **/ /*#define HAS_SOCKADDR_SA_LEN / **/ -/*#define HAS_MSG_CTRUNC / **/ -/*#define HAS_MSG_DONTROUTE / **/ -/*#define HAS_MSG_OOB / **/ -/*#define HAS_MSG_PEEK / **/ -/*#define HAS_MSG_PROXY / **/ -/*#define HAS_SCM_RIGHTS / **/ /*#define HAS_SOCKADDR_IN6 / **/ #define HAS_SIN6_SCOPE_ID /**/ /*#define HAS_IP_MREQ / **/ @@ -3666,24 +3630,12 @@ */ /*#define HAS_FREXPL / **/ -/* HAS_STRUCT_FS_DATA: - * This symbol, if defined, indicates that the struct fs_data - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_FS_DATA / **/ - /* HAS_FSEEKO: * This symbol, if defined, indicates that the fseeko routine is * available to fseek beyond 32 bits (useful for ILP32 hosts). */ /*#define HAS_FSEEKO / **/ -/* HAS_FSTATFS: - * This symbol, if defined, indicates that the fstatfs routine is - * available to stat filesystems by file descriptors. - */ -/*#define HAS_FSTATFS / **/ - /* HAS_FSYNC: * This symbol, if defined, indicates that the fsync routine is * available to write a file's modified data and attributes to @@ -3721,30 +3673,12 @@ */ /*#define HAS_GETESPWNAM / **/ -/* HAS_GETFSSTAT: - * This symbol, if defined, indicates that the getfsstat routine is - * available to stat filesystems in bulk. - */ -/*#define HAS_GETFSSTAT / **/ - /* HAS_GETITIMER: * This symbol, if defined, indicates that the getitimer routine is * available to return interval timers. */ /*#define HAS_GETITIMER / **/ -/* HAS_GETMNT: - * This symbol, if defined, indicates that the getmnt routine is - * available to get filesystem mount info by filename. - */ -/*#define HAS_GETMNT / **/ - -/* HAS_GETMNTENT: - * This symbol, if defined, indicates that the getmntent routine is - * available to iterate through mounted file systems to get their info. - */ -/*#define HAS_GETMNTENT / **/ - /* HAS_GETNAMEINFO: * This symbol, if defined, indicates that the getnameinfo() function * is available for use. @@ -3763,12 +3697,6 @@ */ /*#define HAS_GETSPNAM / **/ -/* HAS_HASMNTOPT: - * This symbol, if defined, indicates that the hasmntopt routine is - * available to query the mount options of file systems. - */ -/*#define HAS_HASMNTOPT / **/ - /* HAS_ILOGBL: * This symbol, if defined, indicates that the ilogbl routine is * available. If scalbnl is also present we can emulate frexpl. @@ -3905,16 +3833,8 @@ * a prototype for the modfl() function. Otherwise, it is up * to the program to supply one. */ -/* HAS_MODFL_POW32_BUG: - * This symbol, if defined, indicates that the modfl routine is - * broken for long doubles >= pow(2, 32). - * For example from 4294967303.150000 one would get 4294967302.000000 - * and 1.150000. The bug has been seen in certain versions of glibc, - * release 2.2.2 is known to be okay. - */ /*#define HAS_MODFL / **/ /*#define HAS_MODFL_PROTO / **/ -/*#define HAS_MODFL_POW32_BUG / **/ /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is @@ -4109,29 +4029,6 @@ */ /*#define HAS_SETRESUID_PROTO / **/ -/* HAS_STRUCT_STATFS_F_FLAGS: - * This symbol, if defined, indicates that the struct statfs - * does have the f_flags member containing the mount flags of - * the filesystem containing the file. - * This kind of struct statfs is coming from (BSD 4.3), - * not from (SYSV). Older BSDs (like Ultrix) do not - * have statfs() and struct statfs, they have ustat() and getmnt() - * with struct ustat and struct fs_data. - */ -/*#define HAS_STRUCT_STATFS_F_FLAGS / **/ - -/* HAS_STRUCT_STATFS: - * This symbol, if defined, indicates that the struct statfs - * to do statfs() is supported. - */ -/*#define HAS_STRUCT_STATFS / **/ - -/* HAS_FSTATVFS: - * This symbol, if defined, indicates that the fstatvfs routine is - * available to stat filesystems by file descriptors. - */ -/*#define HAS_FSTATVFS / **/ - /* HAS_STRFTIME: * This symbol, if defined, indicates that the strftime routine is * available to do time formatting. @@ -4275,12 +4172,6 @@ */ /*#define HAS_USLEEP_PROTO / **/ -/* HAS_USTAT: - * This symbol, if defined, indicates that the ustat system call is - * available to query file system statistics by dev_t. - */ -/*#define HAS_USTAT / **/ - /* HAS_WCSCMP: * This symbol, if defined, indicates that the wcscmp routine is * available to compare two wide character strings. @@ -4417,12 +4308,6 @@ */ /*#define I_MALLOCMALLOC / **/ -/* I_MNTENT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_MNTENT / **/ - /* I_NETINET_TCP: * This symbol, if defined, indicates to the C program that it should * include . @@ -4483,41 +4368,12 @@ */ /*#define I_SYSMODE / **/ -/* I_SYS_MOUNT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_MOUNT / **/ - -/* I_SYS_STATFS: - * This symbol, if defined, indicates that exists. - */ -/*#define I_SYS_STATFS / **/ - -/* I_SYS_STATVFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_STATVFS / **/ - /* I_SYSUTSNAME: * This symbol, if defined, indicates that exists and * should be included. */ /*#define I_SYSUTSNAME / **/ -/* I_SYS_VFS: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_SYS_VFS / **/ - -/* I_USTAT: - * This symbol, if defined, indicates that exists and - * should be included. - */ -/*#define I_USTAT / **/ - /* PERL_PRIfldbl: * This symbol, if defined, contains the string used by stdio to * format long doubles (format 'f') for output. diff --git a/win32/makefile.mk b/win32/makefile.mk index 01ea7fb..83850c3 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -44,7 +44,7 @@ INST_TOP *= $(INST_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -#INST_VER *= \5.23.3 +#INST_VER *= \5.23.4 # # Comment this out if you DON'T want your perl installation to have @@ -108,6 +108,13 @@ USE_LARGE_FILES *= define #USE_LONG_DOUBLE *=define # +# Uncomment this if you want to disable looking up values from +# HKEY_CURRENT_USER\Software\Perl and HKEY_LOCAL_MACHINE\Software\Perl in +# the Registry. +# +#USE_NO_REGISTRY *=define + +# # uncomment exactly one of the following # # Visual C++ 6.0 (aka Visual C++ 98) @@ -310,6 +317,7 @@ USE_IMP_SYS *= undef USE_LARGE_FILES *= undef USE_64_BIT_INT *= undef USE_LONG_DOUBLE *= undef +USE_NO_REGISTRY *= undef .IF "$(USE_IMP_SYS)" == "define" PERL_MALLOC = undef @@ -343,6 +351,10 @@ BUILDOPT += -DPERL_IMPLICIT_CONTEXT BUILDOPT += -DPERL_IMPLICIT_SYS .ENDIF +.IF "$(USE_NO_REGISTRY)" != "undef" +BUILDOPT += -DWIN32_NO_REGISTRY +.ENDIF + PROCESSOR_ARCHITECTURE *= x86 .IF "$(WIN64)" == "undef" @@ -524,7 +536,16 @@ TESTPREPGCC = test-prep-gcc # All but the free version of VC++ 7.1 can load DLLs on demand. Makes the test # suite run in about 10% less time. .IF "$(CCTYPE)" != "MSVC70FREE" +# If no registry, advapi32 is only used for Perl_pp_getlogin/getlogin/GetUserNameA +# which is rare to execute +.IF "$(USE_NO_REGISTRY)" != "undef" +DELAYLOAD = -DELAYLOAD:ws2_32.dll -DELAYLOAD:advapi32.dll delayimp.lib +MINIDELAYLOAD = +.ELSE DELAYLOAD = -DELAYLOAD:ws2_32.dll delayimp.lib +#miniperl never does any registry lookups +MINIDELAYLOAD = -DELAYLOAD:advapi32.dll +.ENDIF .ENDIF # Visual C++ 2005 and 2008 (VC++ 8.0 and 9.0) create manifest files for EXEs and @@ -1116,7 +1137,7 @@ $(CONFIGPM): ..\config.sh config_h.PL $(mktmp $(LKPRE) $(MINI_OBJ) $(LIBFILES) $(LKPOST)) .ELSE $(LINK32) -out:$(MINIPERL) $(BLINK_FLAGS) \ - @$(mktmp $(DELAYLOAD) $(LIBFILES) $(MINI_OBJ)) + @$(mktmp $(DELAYLOAD) $(MINIDELAYLOAD) $(LIBFILES) $(MINI_OBJ)) $(EMBED_EXE_MANI:s/$@/$(MINIPERL)/) .ENDIF $(MINIPERL) -I..\lib -f ..\write_buildcustomize.pl .. @@ -1522,7 +1543,7 @@ utils: $(HAVEMINIPERL) ..\utils\Makefile copy ..\README.tw ..\pod\perltw.pod copy ..\README.vos ..\pod\perlvos.pod copy ..\README.win32 ..\pod\perlwin32.pod - copy ..\pod\perldelta.pod ..\pod\perl5233delta.pod + copy ..\pod\perldelta.pod ..\pod\perl5234delta.pod $(MINIPERL) -I..\lib $(PL2BAT) $(UTILS) $(MINIPERL) -I..\lib ..\autodoc.pl .. $(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q .. @@ -1618,7 +1639,7 @@ distclean: realclean -if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API -if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS -cd $(PODDIR) && del /f *.html *.bat roffitall \ - perl5233delta.pod perlaix.pod perlamiga.pod perlandroid.pod \ + perl5234delta.pod perlaix.pod perlamiga.pod perlandroid.pod \ perlapi.pod perlbs2000.pod perlce.pod perlcn.pod perlcygwin.pod \ perldos.pod perlfreebsd.pod perlhaiku.pod perlhpux.pod \ perlhurd.pod perlintern.pod perlirix.pod perljp.pod perlko.pod \ diff --git a/win32/perlhost.h b/win32/perlhost.h index 7a0c3b3..9963319 100644 --- a/win32/perlhost.h +++ b/win32/perlhost.h @@ -329,7 +329,7 @@ PerlMemIsLocked(struct IPerlMem* piPerl) return IPERL2HOST(piPerl)->IsLocked(); } -struct IPerlMem perlMem = +const struct IPerlMem perlMem = { PerlMemMalloc, PerlMemRealloc, @@ -383,7 +383,7 @@ PerlMemSharedIsLocked(struct IPerlMem* piPerl) return IPERL2HOST(piPerl)->IsLockedShared(); } -struct IPerlMem perlMemShared = +const struct IPerlMem perlMemShared = { PerlMemSharedMalloc, PerlMemSharedRealloc, @@ -437,7 +437,7 @@ PerlMemParseIsLocked(struct IPerlMem* piPerl) return IPERL2HOST(piPerl)->IsLockedParse(); } -struct IPerlMem perlMemParse = +const struct IPerlMem perlMemParse = { PerlMemParseMalloc, PerlMemParseRealloc, @@ -514,9 +514,9 @@ PerlEnvOsId(struct IPerlEnv* piPerl) } char* -PerlEnvLibPath(struct IPerlEnv* piPerl, const char *pl, STRLEN *const len) +PerlEnvLibPath(struct IPerlEnv* piPerl, WIN32_NO_REGISTRY_M_(const char *pl) STRLEN *const len) { - return win32_get_privlib(pl, len); + return win32_get_privlib(WIN32_NO_REGISTRY_M_(pl) len); } char* @@ -538,7 +538,7 @@ PerlEnvGetChildIO(struct IPerlEnv* piPerl, child_IO_table* ptr) win32_get_child_IO(ptr); } -struct IPerlEnv perlEnv = +const struct IPerlEnv perlEnv = { PerlEnvGetenv, PerlEnvPutenv, @@ -866,7 +866,7 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf) #endif } -struct IPerlStdIO perlStdIO = +const struct IPerlStdIO perlStdIO = { PerlStdIOStdin, PerlStdIOStdout, @@ -1077,7 +1077,7 @@ PerlLIOWrite(struct IPerlLIO* piPerl, int handle, const void *buffer, unsigned i return win32_write(handle, buffer, count); } -struct IPerlLIO perlLIO = +const struct IPerlLIO perlLIO = { PerlLIOAccess, PerlLIOChmod, @@ -1178,7 +1178,7 @@ PerlDirMapPathW(struct IPerlDir* piPerl, const WCHAR* path) return IPERL2HOST(piPerl)->MapPathW(path); } -struct IPerlDir perlDir = +const struct IPerlDir perlDir = { PerlDirMakedir, PerlDirChdir, @@ -1464,7 +1464,7 @@ PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp) return win32_ioctlsocket(s, cmd, argp); } -struct IPerlSock perlSock = +const struct IPerlSock perlSock = { PerlSockHtonl, PerlSockHtons, @@ -1898,7 +1898,7 @@ PerlProcLastHost(struct IPerlProc* piPerl) return h->LastHost(); } -struct IPerlProc perlProc = +const struct IPerlProc perlProc = { PerlProcAbort, PerlProcCrypt, diff --git a/win32/pod.mak b/win32/pod.mak index f55aa42..92addae 100644 --- a/win32/pod.mak +++ b/win32/pod.mak @@ -45,6 +45,7 @@ POD = perl.pod \ perl5231delta.pod \ perl5232delta.pod \ perl5233delta.pod \ + perl5234delta.pod \ perl561delta.pod \ perl56delta.pod \ perl581delta.pod \ @@ -184,6 +185,7 @@ MAN = perl.man \ perl5231delta.man \ perl5232delta.man \ perl5233delta.man \ + perl5234delta.man \ perl561delta.man \ perl56delta.man \ perl581delta.man \ @@ -323,6 +325,7 @@ HTML = perl.html \ perl5231delta.html \ perl5232delta.html \ perl5233delta.html \ + perl5234delta.html \ perl561delta.html \ perl56delta.html \ perl581delta.html \ @@ -462,6 +465,7 @@ TEX = perl.tex \ perl5231delta.tex \ perl5232delta.tex \ perl5233delta.tex \ + perl5234delta.tex \ perl561delta.tex \ perl56delta.tex \ perl581delta.tex \ diff --git a/win32/win32.c b/win32/win32.c index 2b883a2..1f6bd91 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -114,12 +114,17 @@ static void my_invalid_parameter_handler(const wchar_t* expression, unsigned int line, uintptr_t pReserved); #endif +#ifndef WIN32_NO_REGISTRY static char* get_regstr_from(HKEY hkey, const char *valuename, SV **svp); static char* get_regstr(const char *valuename, SV **svp); +#endif + static char* get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing, ...); -static char* win32_get_xlib(const char *pl, const char *xlib, +static char* win32_get_xlib(const char *pl, + WIN32_NO_REGISTRY_M_(const char *xlib) const char *libname, STRLEN *const len); + static BOOL has_shell_metachars(const char *ptr); static long tokenize(const char *str, char **dest, char ***destv); static void get_shell(void); @@ -167,6 +172,12 @@ END_EXTERN_C static OSVERSIONINFO g_osver = {0, 0, 0, 0, 0, ""}; +#ifndef WIN32_NO_REGISTRY +/* initialized by Perl_win32_init/PERL_SYS_INIT */ +static HKEY HKCU_Perl_hnd; +static HKEY HKLM_Perl_hnd; +#endif + #ifdef SET_INVALID_PARAMETER_HANDLER static BOOL silent_invalid_parameter_handler = FALSE; @@ -254,36 +265,31 @@ set_w32_module_name(void) } } +#ifndef WIN32_NO_REGISTRY /* *svp (if non-NULL) is expected to be POK (valid allocated SvPVX(*svp)) */ static char* -get_regstr_from(HKEY hkey, const char *valuename, SV **svp) +get_regstr_from(HKEY handle, const char *valuename, SV **svp) { /* Retrieve a REG_SZ or REG_EXPAND_SZ from the registry */ - HKEY handle; DWORD type; - const char *subkey = "Software\\Perl"; char *str = NULL; long retval; + DWORD datalen; - retval = RegOpenKeyEx(hkey, subkey, 0, KEY_READ, &handle); - if (retval == ERROR_SUCCESS) { - DWORD datalen; - retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen); - if (retval == ERROR_SUCCESS - && (type == REG_SZ || type == REG_EXPAND_SZ)) - { - dTHX; - if (!*svp) - *svp = sv_2mortal(newSVpvs("")); - SvGROW(*svp, datalen); - retval = RegQueryValueEx(handle, valuename, 0, NULL, - (PBYTE)SvPVX(*svp), &datalen); - if (retval == ERROR_SUCCESS) { - str = SvPVX(*svp); - SvCUR_set(*svp,datalen-1); - } + retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen); + if (retval == ERROR_SUCCESS + && (type == REG_SZ || type == REG_EXPAND_SZ)) + { + dTHX; + if (!*svp) + *svp = sv_2mortal(newSVpvs("")); + SvGROW(*svp, datalen); + retval = RegQueryValueEx(handle, valuename, 0, NULL, + (PBYTE)SvPVX(*svp), &datalen); + if (retval == ERROR_SUCCESS) { + str = SvPVX(*svp); + SvCUR_set(*svp,datalen-1); } - RegCloseKey(handle); } return str; } @@ -292,11 +298,22 @@ get_regstr_from(HKEY hkey, const char *valuename, SV **svp) static char* get_regstr(const char *valuename, SV **svp) { - char *str = get_regstr_from(HKEY_CURRENT_USER, valuename, svp); - if (!str) - str = get_regstr_from(HKEY_LOCAL_MACHINE, valuename, svp); + char *str; + if (HKCU_Perl_hnd) { + str = get_regstr_from(HKCU_Perl_hnd, valuename, svp); + if (!str) + goto try_HKLM; + } + else { + try_HKLM: + if (HKLM_Perl_hnd) + str = get_regstr_from(HKLM_Perl_hnd, valuename, svp); + else + str = NULL; + } return str; } +#endif /* ifndef WIN32_NO_REGISTRY */ /* *prev_pathp (if non-NULL) is expected to be POK (valid allocated SvPVX(sv)) */ static char * @@ -366,41 +383,49 @@ get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...) } EXTERN_C char * -win32_get_privlib(const char *pl, STRLEN *const len) +win32_get_privlib(WIN32_NO_REGISTRY_M_(const char *pl) STRLEN *const len) { char *stdlib = "lib"; - char buffer[MAX_PATH+1]; SV *sv = NULL; +#ifndef WIN32_NO_REGISTRY + char buffer[MAX_PATH+1]; /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */ sprintf(buffer, "%s-%s", stdlib, pl); if (!get_regstr(buffer, &sv)) (void)get_regstr(stdlib, &sv); +#endif /* $stdlib .= ";$EMD/../../lib" */ return get_emd_part(&sv, len, stdlib, ARCHNAME, "bin", NULL); } static char * -win32_get_xlib(const char *pl, const char *xlib, const char *libname, - STRLEN *const len) +win32_get_xlib(const char *pl, WIN32_NO_REGISTRY_M_(const char *xlib) + const char *libname, STRLEN *const len) { +#ifndef WIN32_NO_REGISTRY char regstr[40]; +#endif char pathstr[MAX_PATH+1]; SV *sv1 = NULL; SV *sv2 = NULL; +#ifndef WIN32_NO_REGISTRY /* $HKCU{"$xlib-$]"} || $HKLM{"$xlib-$]"} . ---; */ sprintf(regstr, "%s-%s", xlib, pl); (void)get_regstr(regstr, &sv1); +#endif /* $xlib .= * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/$]/lib"; */ sprintf(pathstr, "%s/%s/lib", libname, pl); (void)get_emd_part(&sv1, NULL, pathstr, ARCHNAME, "bin", pl, NULL); +#ifndef WIN32_NO_REGISTRY /* $HKCU{$xlib} || $HKLM{$xlib} . ---; */ (void)get_regstr(xlib, &sv2); +#endif /* $xlib .= * ";$EMD/" . ((-d $EMD/../../../$]) ? "../../.." : "../.."). "/$libname/lib"; */ @@ -425,7 +450,7 @@ win32_get_xlib(const char *pl, const char *xlib, const char *libname, EXTERN_C char * win32_get_sitelib(const char *pl, STRLEN *const len) { - return win32_get_xlib(pl, "sitelib", "site", len); + return win32_get_xlib(pl, WIN32_NO_REGISTRY_M_("sitelib") "site", len); } #ifndef PERL_VENDORLIB_NAME @@ -435,7 +460,7 @@ win32_get_sitelib(const char *pl, STRLEN *const len) EXTERN_C char * win32_get_vendorlib(const char *pl, STRLEN *const len) { - return win32_get_xlib(pl, "vendorlib", PERL_VENDORLIB_NAME, len); + return win32_get_xlib(pl, WIN32_NO_REGISTRY_M_("vendorlib") PERL_VENDORLIB_NAME, len); } static BOOL @@ -1438,10 +1463,6 @@ win32_stat(const char *path, Stat_t *sbuf) int nlink = 1; BOOL expect_dir = FALSE; - GV *gv_sloppy = gv_fetchpvs("\027IN32_SLOPPY_STAT", - GV_NOTQUAL, SVt_PV); - BOOL sloppy = gv_sloppy && SvTRUE(GvSV(gv_sloppy)); - if (l > 1) { switch(path[l - 1]) { /* FindFirstFile() and stat() are buggy with a trailing @@ -1482,7 +1503,7 @@ win32_stat(const char *path, Stat_t *sbuf) path = PerlDir_mapA(path); l = strlen(path); - if (!sloppy) { + if (!w32_sloppystat) { /* We must open & close the file once; otherwise file attribute changes */ /* might not yet have propagated to "other" hard links of the same file. */ /* This also gives us an opportunity to determine the number of links. */ @@ -1816,12 +1837,14 @@ win32_getenv(const char *name) } FreeEnvironmentStrings(envv); } +#ifndef WIN32_NO_REGISTRY else { /* last ditch: allow any environment variables that begin with 'PERL' to be obtained from the registry, if found there */ if (strncmp(name, "PERL", 4) == 0) (void)get_regstr(name, &curitem); } +#endif } if (curitem && SvCUR(curitem)) return SvPVX(curitem); @@ -4443,6 +4466,20 @@ Perl_win32_init(int *argcp, char ***argvp) #endif ansify_path(); + +#ifndef WIN32_NO_REGISTRY + { + LONG retval; + retval = RegOpenKeyExW(HKEY_CURRENT_USER, L"SOFTWARE\\Perl", 0, KEY_READ, &HKCU_Perl_hnd); + if (retval != ERROR_SUCCESS) { + HKCU_Perl_hnd = NULL; + } + retval = RegOpenKeyExW(HKEY_LOCAL_MACHINE, L"SOFTWARE\\Perl", 0, KEY_READ, &HKLM_Perl_hnd); + if (retval != ERROR_SUCCESS) { + HKLM_Perl_hnd = NULL; + } + } +#endif } void @@ -4452,6 +4489,13 @@ Perl_win32_term(void) OP_REFCNT_TERM; PERLIO_TERM; MALLOC_TERM; +#ifndef WIN32_NO_REGISTRY + /* handles might be NULL, RegCloseKey then returns ERROR_INVALID_HANDLE + but no point of checking and we can't die() at this point */ + RegCloseKey(HKLM_Perl_hnd); + RegCloseKey(HKCU_Perl_hnd); + /* the handles are in an undefined state until the next PERL_SYS_INIT3 */ +#endif } void @@ -4633,6 +4677,11 @@ Perl_sys_intern_init(pTHX) w32_timerid = 0; w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE); w32_poll_count = 0; +#ifdef PERL_IS_MINIPERL + w32_sloppystat = TRUE; +#else + w32_sloppystat = FALSE; +#endif for (i=0; i < SIG_SIZE; i++) { w32_sighandler[i] = SIG_DFL; } @@ -4700,6 +4749,7 @@ Perl_sys_intern_dup(pTHX_ struct interp_intern *src, struct interp_intern *dst) dst->timerid = 0; dst->message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE); dst->poll_count = 0; + dst->sloppystat = src->sloppystat; Copy(src->sigtable,dst->sigtable,SIG_SIZE,Sighandler_t); } # endif /* USE_ITHREADS */ diff --git a/win32/win32.h b/win32/win32.h index 3b35b6c..9b79e00 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -24,6 +24,9 @@ /* less I/O calls during each require */ # define PERL_DISABLE_PMC +/* unnecessery for miniperl to lookup anything from an "installed" perl */ +# define WIN32_NO_REGISTRY + /* allow minitest to work */ # define PERL_TEXTMODE_SCRIPTS #endif @@ -206,6 +209,13 @@ struct utsname { # define PERL_SOCK_SYSWRITE_IS_SEND #endif +#ifdef WIN32_NO_REGISTRY +/* the last _ in WIN32_NO_REGISTRY_M_ is like the _ in aTHX_ */ +# define WIN32_NO_REGISTRY_M_(x) +#else +# define WIN32_NO_REGISTRY_M_(x) x, +#endif + #define PERL_NO_FORCE_LINK /* no need for PL_force_link_funcs */ #define ENV_IS_CASELESS @@ -394,7 +404,7 @@ DllExport HWND win32_create_message_window(void); DllExport int win32_async_check(pTHX); extern int my_fclose(FILE *); -extern char * win32_get_privlib(const char *pl, STRLEN *const len); +extern char * win32_get_privlib(WIN32_NO_REGISTRY_M_(const char *pl) STRLEN *const len); extern char * win32_get_sitelib(const char *pl, STRLEN *const len); extern char * win32_get_vendorlib(const char *pl, STRLEN *const len); @@ -494,6 +504,7 @@ struct interp_intern { UINT timerid; unsigned poll_count; Sighandler_t sigtable[SIG_SIZE]; + bool sloppystat; }; #define WIN32_POLL_INTERVAL 32768 @@ -527,6 +538,7 @@ struct interp_intern { #define w32_init_socktype (PL_sys_intern.thr_intern.Winit_socktype) #define w32_use_showwindow (PL_sys_intern.thr_intern.Wuse_showwindow) #define w32_showwindow (PL_sys_intern.thr_intern.Wshowwindow) +#define w32_sloppystat (PL_sys_intern.sloppystat) #ifdef USE_ITHREADS void win32_wait_for_children(pTHX); diff --git a/win32/wince.c b/win32/wince.c index 1b58d40..bcc66c8 100644 --- a/win32/wince.c +++ b/win32/wince.c @@ -230,7 +230,7 @@ get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...) } char * -win32_get_privlib(const char *pl, STRLEN *const len) +win32_get_privlib(WIN32_NO_REGISTRY_M_(const char *pl) STRLEN *const len) { dTHX; char *stdlib = "lib"; diff --git a/write_buildcustomize.pl b/write_buildcustomize.pl index 68e300f..cf56e33 100644 --- a/write_buildcustomize.pl +++ b/write_buildcustomize.pl @@ -87,7 +87,6 @@ print $fh <<"EOT" or $error = "Can't print to $file: $!"; # We are miniperl, building extensions # Replace the first entry of \@INC ("lib") with the list of # directories we need. -${\($^O eq 'MSWin32' ? '${^WIN32_SLOPPY_STAT} = 1;':'')} splice(\@INC, 0, 1, $inc); \$^O = '$osname'; __END__ -- 2.7.4