From: DongHun Kwak Date: Wed, 28 Jun 2017 01:29:49 +0000 (+0900) Subject: Imported Upstream version 5.21.2 X-Git-Tag: upstream/5.21.3~1 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=refs%2Fchanges%2F15%2F136015%2F1;p=platform%2Fupstream%2Fperl.git Imported Upstream version 5.21.2 Change-Id: I3b35ae62c9a45a990669017d33f8839b076644b6 Signed-off-by: DongHun Kwak --- diff --git a/AUTHORS b/AUTHORS index 4740185..177e64d 100644 --- a/AUTHORS +++ b/AUTHORS @@ -336,6 +336,7 @@ Devin Heitmueller DH Diab Jerius dLux +Dmitri Tikhonov Dmitry Karasik Dominic Dunlop Dominic Hargreaves diff --git a/Configure b/Configure index 4e6315d..a267266 100755 --- a/Configure +++ b/Configure @@ -650,6 +650,7 @@ d_pthread_attr_setscope='' d_pthread_yield='' d_sched_yield='' sched_yield='' +d_ptrdiff_t='' d_qgcvt='' d_random_r='' random_r_proto='' @@ -934,7 +935,6 @@ i_sysin='' i_poll='' i_prot='' i_pthread='' -d_ptrdiff_t='' d_pwage='' d_pwchange='' d_pwclass='' @@ -8318,8 +8318,8 @@ EOM case "$ccdlflags" in '') case "$osname" in *linux*|hpux|gnu*) dflt='-Wl,-E' ;; - sunos) dflt='none' ;; - *) dflt='none' ;; + sunos) dflt='none' ;; + *) dflt='none' ;; esac ;; ' ') dflt='none' ;; *) dflt="$ccdlflags" ;; @@ -12997,11 +12997,15 @@ int main() int pu[2]; char buf[1]; char string[100]; - - pipe(pd); /* Down: child -> parent */ - pipe(pu); /* Up: parent -> child */ + int ret; + + ret = pipe(pd); /* Down: child -> parent */ + if (ret != 0) + exit(3); + ret = pipe(pu); /* Up: parent -> child */ + if (ret != 0) + exit(3); if (0 != fork()) { - int ret; close(pd[1]); /* Parent reads from pd[0] */ close(pu[0]); /* Parent writes (blocking) to pu[1] */ #ifdef F_SETFL @@ -13015,7 +13019,9 @@ int main() if ((ret = read(pd[0], buf, 1)) > 0) /* Nothing to read! */ exit(2); sprintf(string, "%d\n", ret); - write(2, string, strlen(string)); + ret = write(2, string, strlen(string)); + if (ret != strlen(string)) + exit(3); alarm(0); #ifdef EAGAIN if (errno == EAGAIN) { @@ -13028,19 +13034,25 @@ int main() printf("EWOULDBLOCK\n"); #endif ok: - write(pu[1], buf, 1); /* Unblocks child, tell it to close our pipe */ + ret = write(pu[1], buf, 1); /* Unblocks child, tell it to close our pipe */ + if (ret != 1) + exit(3); sleep(2); /* Give it time to close our pipe */ alarm(5); ret = read(pd[0], buf, 1); /* Should read EOF */ alarm(0); sprintf(string, "%d\n", ret); - write(4, string, strlen(string)); + ret = write(4, string, strlen(string)); + if (ret != strlen(string)) + exit(3); exit(0); } close(pd[0]); /* We write to pd[1] */ close(pu[1]); /* We read from pu[0] */ - read(pu[0], buf, 1); /* Wait for parent to signal us we may continue */ + ret = read(pu[0], buf, 1); /* Wait for parent to signal us we may continue */ + if (ret != 1) + exit(3); close(pd[1]); /* Pipe pd is now fully closed! */ exit(0); /* Bye bye, thank you for playing! */ } @@ -16355,25 +16367,6 @@ $rm_try set d_off64_t eval $setvar -: check for ptrdiff_t -echo " " -echo "Checking to see if you have ptrdiff_t..." >&4 -$cat >try.c < -int main() { ptrdiff_t x = 7; } -EOCP -set try -if eval $compile; then - val="$define" - echo "You have ptrdiff_t." -else - val="$undef" - echo "You do not have ptrdiff_t." -fi -$rm_try -set d_ptrdiff_t -eval $setvar - : how to create joinable pthreads if test "X$usethreads" = "X$define" -a "X$i_pthread" = "X$define"; then echo " " @@ -16645,6 +16638,25 @@ case "$sched_yield" in esac $rm_try +: check for ptrdiff_t +echo " " +echo "Checking to see if you have ptrdiff_t..." >&4 +$cat >try.c < +int main() { ptrdiff_t x = 7; } +EOCP +set try +if eval $compile; then + val="$define" + echo "You have ptrdiff_t." +else + val="$undef" + echo "You do not have ptrdiff_t." +fi +$rm_try +set d_ptrdiff_t +eval $setvar + : see if random_r exists set random_r d_random_r eval $inlibc @@ -19517,9 +19529,7 @@ define) #include #ifndef DB_VERSION_MAJOR -u_int32_t hash_cb (ptr, size) -const void *ptr; -size_t size; +u_int32_t hash_cb (const void* ptr, size_t size) { } HASHINFO info; @@ -19562,9 +19572,7 @@ define) #include #ifndef DB_VERSION_MAJOR -size_t prefix_cb (key1, key2) -const DBT *key1; -const DBT *key2; +size_t prefix_cb (const DBT *key1, const DBT *key2) { } BTREEINFO info; @@ -21990,70 +21998,69 @@ eval $inhdr echo " " $echo "Guessing which symbols your C compiler and preprocessor define..." >&4 $cat <<'EOSH' > Cppsym.know -a29k ABI64 aegis AES_SOURCE AIX AIX32 AIX370 -AIX41 AIX42 AIX43 AIX_SOURCE aixpc ALL_SOURCE -alliant alpha am29000 AM29000 AMD64 amd64 amiga AMIGAOS AMIX -ansi ANSI_C_SOURCE apollo ardent ARM32 atarist att386 att3b -BeOS BIG_ENDIAN BIT_MSF bsd BSD bsd43 bsd4_2 bsd4_3 BSD4_3 bsd4_4 -BSD_4_3 BSD_4_4 BSD_NET2 BSD_TIME BSD_TYPES BSDCOMPAT bsdi -bull c cadmus clipper CMU COFF COMPILER_VERSION -concurrent convex cpu cray CRAY CRAYMPP ctix CX_UX -CYGWIN DECC DGUX DGUX_SOURCE DJGPP dmert DOLPHIN DPX2 DSO -Dynix DynixPTX ELF encore EPI EXTENSIONS FAVOR_BSD -FILE_OFFSET_BITS FreeBSD GCC_NEW_VARARGS gcos gcx gimpel -GLIBC GLIBC_MINOR -GNU_SOURCE GNUC GNUC_MINOR GNU_LIBRARY GO32 gould GOULD_PN -H3050R H3050RX hbullx20 hcx host_mips -hp200 hp300 hp700 HP700 hp800 hp9000 -hp9000s200 hp9000s300 hp9000s400 hp9000s500 -hp9000s700 hp9000s800 hp9k8 hp_osf hppa hpux HPUX_SOURCE -i186 i286 i386 i486 i586 i686 i8086 i80960 i860 I960 -IA64 iAPX286 ibm ibm032 ibmesa IBMR2 ibmrt ILP32 ILP64 -INLINE_INTRINSICS INTRINSICS INT64 interdata is68k ksr1 -LANGUAGE_C LARGE_FILE_API LARGEFILE64_SOURCE -LARGEFILE_SOURCE LFS64_LARGEFILE LFS_LARGEFILE -LIBCATAMOUNT Linux LITTLE_ENDIAN LONG64 LONG_DOUBLE LONG_LONG -LONGDOUBLE LONGLONG LP64 luna luna88k Lynx -M68000 m68k m88100 m88k M88KBCS_TARGET M_COFF -M_I186 M_I286 M_I386 M_I8086 M_I86 M_I86SM M_SYS3 -M_SYS5 M_SYSIII M_SYSV M_UNIX M_XENIX MACH machine MachTen -MATH_HAS_NO_SIDE_EFFECTS -mc300 mc500 mc68000 mc68010 mc68020 mc68030 mc68040 -mc68060 mc68k mc68k32 mc700 mc88000 mc88100 merlin -mert MiNT mips MIPS_FPSET MIPS_ISA MIPS_SIM MIPS_SZINT -MIPS_SZLONG MIPS_SZPTR MIPSEB MIPSEL MODERN_C motorola -mpeix MSDOS MTXINU MULTIMAX mvs MVS n16 ncl_el ncl_mr -NetBSD news1500 news1700 news1800 news1900 news3700 -news700 news800 news900 NeXT NLS nonstopux ns16000 ns32000 -ns32016 ns32332 ns32k nsc32000 +a29k aarch64 ABI64 aegis AES_SOURCE AIX AIX32 AIX370 AIX41 AIX42 +AIX43 aixpc AIX_SOURCE alliant ALL_SOURCE alpha AM29000 am29000 +AMD64 amd64 amiga AMIGAOS AMIX ansi ANSI_C_SOURCE apollo arch_ppc +arch_pwr ardent ARM ARM32 atarist att386 att3b +BeOS BIG_ENDIAN BIT_MSF BSD bsd bsd43 bsd4_2 BSD4_3 bsd4_3 bsd4_4 +BSDCOMPAT bsdi BSD_4_3 BSD_4_4 BSD_NET2 BSD_TIME BSD_TYPES bull +byteorder byte_order +c cadmus clang clipper CMU COFF COMPILER_VERSION concurrent +convex cpu CRAY cray CRAYMPP ctix CX_UX CYGWIN +DECC DGUX DGUX_SOURCE DJGPP dmert DOLPHIN DPX2 DSO Dynix DynixPTX +ELF encore EPI EXTENSIONS +FAVOR_BSD FILE_OFFSET_BITS FORTIFY_SOURCE FreeBSD +GCC_NEW_VARARGS gcos gcx gimpel GLIBC GLIBC_MINOR GNUC GNUC_MINOR +GNU_LIBRARY GNU_SOURCE GO32 gould GOULD_PN +H3050R H3050RX hbullx20 hcx host_mips hp200 hp300 HP700 hp700 +hp800 hp9000 hp9000s200 hp9000s300 hp9000s400 hp9000s500 +hp9000s700 hp9000s800 hp9k8 hppa hpux HPUX_SOURCE hp_osf +i186 i286 i386 i486 i586 i686 i8086 i80960 i860 I960 IA32 IA64 +iAPX286 ibm ibm032 ibmesa IBMR2 ibmrt ILP32 ILP64 +INLINE_INTRINSICS INT64 INTEL interdata INTRINSICS is68k itanium +ksr1 +LANGUAGE_C LARGEFILE64_SOURCE LARGEFILE_SOURCE LARGE_FILE_API +LFS64_LARGEFILE LFS_LARGEFILE LIBCATAMOUNT Linux LITTLE_ENDIAN +LONG64 LONGDOUBLE LONGLONG LONG_DOUBLE LONG_LONG LP64 luna +luna88k Lynx +M68000 m68k m88100 m88k M88KBCS_TARGET MACH machine MachTen +MATH_HAS_NO_SIDE_EFFECTS mc300 mc500 mc68000 mc68010 mc68020 +mc68030 mc68040 mc68060 mc68k mc68k32 mc700 mc88000 mc88100 +merlin mert MiNT mips MIPSEB MIPSEL MIPS_FPSET MIPS_ISA MIPS_SIM +MIPS_SZINT MIPS_SZLONG MIPS_SZPTR MODERN_C motorola mpeix MSDOS +MTXINU MULTIMAX MVS mvs M_AMD64 M_ARM M_ARMT M_COFF M_I186 M_I286 +M_I386 M_I8086 M_I86 M_I86SM M_IA64 M_IX86 M_PPC M_SYS3 M_SYS5 +M_SYSIII M_SYSV M_UNIX M_X86 M_XENIX +n16 ncl_el ncl_mr NetBSD news1500 news1700 news1800 news1900 +news3700 news700 news800 news900 NeXT NLS nonstopux ns16000 +ns32000 ns32016 ns32332 ns32k nsc32000 OCS88 OEMVS OpenBSD os OS2 OS390 osf OSF1 OSF_SOURCE -pa_risc PA_RISC1_1 PA_RISC2_0 PARAGON parisc -pc532 pdp11 PGC PIC plexus PORTAR posix -POSIX1B_SOURCE POSIX2_SOURCE POSIX4_SOURCE -POSIX_C_SOURCE POSIX_SOURCE POWER -PROTOTYPES PWB pyr QNX QK_USER R3000 REENTRANT RES Rhapsody RISC6000 -riscix riscos RT S390 SA110 scs SCO sequent sgi SGI_SOURCE SH3 sinix -SIZE_INT SIZE_LONG SIZE_PTR SOCKET_SOURCE SOCKETS_SOURCE -sony sony_news sonyrisc sparc sparclite spectrum -stardent stdc STDC_EXT stratos sun sun3 sun386 -Sun386i svr3 svr4 SVR4_2 SVR4_SOURCE svr5 -SX system SYSTYPE_BSD SYSTYPE_BSD43 SYSTYPE_BSD44 -SYSTYPE_SVR4 SYSTYPE_SVR5 SYSTYPE_SYSV SYSV SYSV3 SYSV4 SYSV5 -sysV68 sysV88 Tek4132 Tek4300 titan -TM3200 TM5400 TM5600 -tower tower32 tower32_200 tower32_600 tower32_700 +PARAGON parisc pa_risc PA_RISC1_1 PA_RISC2_0 pc532 pdp11 PGC PIC +plexus PORTAR posix POSIX1B_SOURCE POSIX2_SOURCE POSIX4_SOURCE +POSIX_C_SOURCE POSIX_SOURCE POWER powerpc ppc PROTOTYPES PWB pyr +QK_USER QNX +R3000 REENTRANT RES Rhapsody RISC6000 riscix riscos RT +S390 S390x SA110 SCO scs sequent sgi SGI_SOURCE SH SH3 sinix +SIZE_INT SIZE_LONG SIZE_PTR SOCKETS_SOURCE SOCKET_SOURCE sony +sonyrisc sony_news sparc sparclite sparcv8 sparcv9 spectrum +stardent stdc STDC_EXT stratos sun sun3 sun386 Sun386i svr3 svr4 +SVR4_2 SVR4_SOURCE svr5 SX system SYSTYPE_BSD SYSTYPE_BSD43 +SYSTYPE_BSD44 SYSTYPE_SVR4 SYSTYPE_SVR5 SYSTYPE_SYSV SYSV SYSV3 +SYSV4 SYSV5 sysV68 sysV88 +Tek4132 Tek4300 thumb thw_370 thw_intel thw_rs6000 titan TM3200 +TM5400 TM5600 tower tower32 tower32_200 tower32_600 tower32_700 tower32_800 tower32_850 tss -u370 u3b u3b2 u3b20 u3b200 u3b20d u3b5 -ultrix UMAXV UnicomPBB UnicomPBD UNICOS UNICOSMK -unix UNIX95 UNIX99 unixpc unos -USE_BSD USE_FILE_OFFSET64 USE_GNU USE_ISOC9X USE_LARGEFILE USE_LARGEFILE64 -USE_MISC USE_POSIX USE_POSIX199309 USE_POSIX199506 USE_POSIX2 -USE_REENTRANT USE_SVID USE_UNIX98 USE_XOPEN USE_XOPEN_EXTENDED -USGr4 USGr4_2 -Utek UTek UTS UWIN uxpm uxps vax venix VMESA vms x86_64 xenix Xenix286 -XOPEN_SOURCE XOPEN_SOURCE_EXTENDED XPG2 XPG2_EXTENDED -XPG3 XPG3_EXTENDED XPG4 XPG4_EXTENDED -z8000 +u370 u3b u3b2 u3b20 u3b200 u3b20d u3b5 ultrix UMAXV UnicomPBB +UnicomPBD UNICOS UNICOSMK unix UNIX95 UNIX99 unixpc unos USE_BSD +USE_FILE_OFFSET64 USE_GNU USE_ISOC9X USE_LARGEFILE +USE_LARGEFILE64 USE_MISC USE_POSIX USE_POSIX199309 +USE_POSIX199506 USE_POSIX2 USE_REENTRANT USE_SVID USE_UNIX98 +USE_XOPEN USE_XOPEN_EXTENDED USGr4 USGr4_2 UTek Utek UTS UWIN +uxpm uxps +vax venix VMESA vms +x86_64 xenix Xenix286 XOPEN_SOURCE XOPEN_SOURCE_EXTENDED XPG2 +XPG2_EXTENDED XPG3 XPG3_EXTENDED XPG4 XPG4_EXTENDED +z8000 zarch EOSH # Maybe put other stuff here too. cat <>Cppsym.know @@ -22069,8 +22076,8 @@ $startsh if $test \$# -gt 0; then echo \$* | $tr " " "$trnl" | ./Cppsym.try > Cppsym.got if $test -s Cppsym.got; then - $rm -f Cppsym.got - exit 0 + $rm -f Cppsym.got + exit 0 fi $rm -f Cppsym.got exit 1 @@ -22159,9 +22166,9 @@ chmod +x ccsym $eunicefix ccsym ./ccsym > ccsym1.raw if $test -s ccsym1.raw; then - $sort ccsym1.raw | $uniq >ccsym.raw + $sort ccsym1.raw | $uniq >ccsym.raw else - mv ccsym1.raw ccsym.raw + mv ccsym1.raw ccsym.raw fi $awk '/\=/ { print $0; next } @@ -22175,9 +22182,9 @@ if $test -z ccsym.raw; then echo " " echo "However, your C preprocessor defines the following symbols:" $cat Cppsym.true - ccsymbols='' + ccsymbols='' cppsymbols=`$cat Cppsym.true` - cppsymbols=`echo $cppsymbols` + cppsymbols=`echo $cppsymbols` cppccsymbols="$cppsymbols" else if $test -s ccsym.com; then @@ -22203,12 +22210,32 @@ else echo "Your C compiler ${also}defines the following cpp symbols:" $sed -e 's/\(..*\)=1/\1/' ccsym.own $sed -e 's/\(..*\)=.*/\1/' ccsym.own | $uniq >>Cppsym.true - ccsymbols=`$cat ccsym.own` - ccsymbols=`echo $ccsymbols` + ccsymbols=`$cat ccsym.own` + ccsymbols=`echo $ccsymbols` $test "$silent" || sleep 1 fi fi +: add -D_FORTIFY_SOURCE if feasible and not already there +case "$gccversion" in +4.*) case "$optimize$ccflags" in + *-O*) case "$ccflags$cppsymbols" in + *_FORTIFY_SOURCE=*) # Don't add it again. + echo "You seem to have -D_FORTIFY_SOURCE already, not adding it." >&4 + ;; + *) echo "Adding -D_FORTIFY_SOURCE=2 to ccflags..." >&4 + ccflags="$ccflags -D_FORTIFY_SOURCE=2" + ;; + esac + ;; + *) echo "You have gcc 4.* but not optimizing, not adding -D_FORTIFY_SOURCE." >&4 + ;; + esac + ;; +*) echo "You seem not to have gcc 4.*, not adding -D_FORTIFY_SOURCE." >&4 + ;; +esac + : see if this is a termio system val="$undef" val2="$undef" diff --git a/Cross/config.sh-arm-linux b/Cross/config.sh-arm-linux index 7a4773d..a5f612e 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='1' +api_subversion='2' api_version='21' -api_versionstring='5.21.1' +api_versionstring='5.21.2' ar='ar' -archlib='/usr/lib/perl5/5.21.1/armv4l-linux' -archlibexp='/usr/lib/perl5/5.21.1/armv4l-linux' +archlib='/usr/lib/perl5/5.21.2/armv4l-linux' +archlibexp='/usr/lib/perl5/5.21.2/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.21.1/armv4l-linux/CORE' +ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.21.2/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' @@ -735,7 +735,7 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='./install_me_here/usr/lib/perl5/5.21.1/armv4l-linux' +installarchlib='./install_me_here/usr/lib/perl5/5.21.2/armv4l-linux' installbin='./install_me_here/usr/bin' installhtml1dir='' installhtml3dir='' @@ -743,13 +743,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.21.1' +installprivlib='./install_me_here/usr/lib/perl5/5.21.2' installscript='./install_me_here/usr/bin' -installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.1/armv4l-linux' +installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.2/armv4l-linux' installsitebin='./install_me_here/usr/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.1' +installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.2' installsiteman1dir='./install_me_here/usr/share/man/man1' installsiteman3dir='./install_me_here/usr/share/man/man3' installsitescript='./install_me_here/usr/bin' @@ -878,8 +878,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/usr/lib/perl5/5.21.1' -privlibexp='/usr/lib/perl5/5.21.1' +privlib='/usr/lib/perl5/5.21.2' +privlibexp='/usr/lib/perl5/5.21.2' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -944,17 +944,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.21.1/armv4l-linux' -sitearchexp='/usr/lib/perl5/site_perl/5.21.1/armv4l-linux' +sitearch='/usr/lib/perl5/site_perl/5.21.2/armv4l-linux' +sitearchexp='/usr/lib/perl5/site_perl/5.21.2/armv4l-linux' sitebin='/usr/bin' sitebinexp='/usr/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/usr/lib/perl5/site_perl/5.21.1' +sitelib='/usr/lib/perl5/site_perl/5.21.2' sitelib_stem='/usr/lib/perl5/site_perl' -sitelibexp='/usr/lib/perl5/site_perl/5.21.1' +sitelibexp='/usr/lib/perl5/site_perl/5.21.2' siteman1dir='/usr/share/man/man1' siteman1direxp='/usr/share/man/man1' siteman3dir='/usr/share/man/man3' @@ -993,7 +993,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='1' +subversion='2' sysman='/usr/share/man/man1' tail='' tar='' @@ -1084,8 +1084,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.21.1' -version_patchlevel_string='version 21 subversion 1' +version='5.21.2' +version_patchlevel_string='version 21 subversion 2' versiononly='undef' vi='' xlibpth='/usr/lib/386 /lib/386' @@ -1099,9 +1099,9 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=21 -PERL_SUBVERSION=1 +PERL_SUBVERSION=2 PERL_API_REVISION=5 PERL_API_VERSION=21 -PERL_API_SUBVERSION=1 +PERL_API_SUBVERSION=2 PERL_PATCHLEVEL= PERL_CONFIG_SH=true diff --git a/Cross/config.sh-arm-linux-n770 b/Cross/config.sh-arm-linux-n770 index 7a0bbf6..fd05947 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='1' +api_subversion='2' api_version='21' -api_versionstring='5.21.1' +api_versionstring='5.21.2' ar='ar' -archlib='/usr/lib/perl5/5.21.1/armv4l-linux' -archlibexp='/usr/lib/perl5/5.21.1/armv4l-linux' +archlib='/usr/lib/perl5/5.21.2/armv4l-linux' +archlibexp='/usr/lib/perl5/5.21.2/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.21.1/armv4l-linux/CORE' +ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.21.2/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' @@ -699,7 +699,7 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='./install_me_here/usr/lib/perl5/5.21.1/armv4l-linux' +installarchlib='./install_me_here/usr/lib/perl5/5.21.2/armv4l-linux' installbin='./install_me_here/usr/bin' installhtml1dir='' installhtml3dir='' @@ -707,13 +707,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.21.1' +installprivlib='./install_me_here/usr/lib/perl5/5.21.2' installscript='./install_me_here/usr/bin' -installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.1/armv4l-linux' +installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.2/armv4l-linux' installsitebin='./install_me_here/usr/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.1' +installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.2' installsiteman1dir='./install_me_here/usr/share/man/man1' installsiteman3dir='./install_me_here/usr/share/man/man3' installsitescript='./install_me_here/usr/bin' @@ -841,8 +841,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/usr/lib/perl5/5.21.1' -privlibexp='/usr/lib/perl5/5.21.1' +privlib='/usr/lib/perl5/5.21.2' +privlibexp='/usr/lib/perl5/5.21.2' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -903,17 +903,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.21.1/armv4l-linux' -sitearchexp='/usr/lib/perl5/site_perl/5.21.1/armv4l-linux' +sitearch='/usr/lib/perl5/site_perl/5.21.2/armv4l-linux' +sitearchexp='/usr/lib/perl5/site_perl/5.21.2/armv4l-linux' sitebin='/usr/bin' sitebinexp='/usr/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/usr/lib/perl5/site_perl/5.21.1' +sitelib='/usr/lib/perl5/site_perl/5.21.2' sitelib_stem='/usr/lib/perl5/site_perl' -sitelibexp='/usr/lib/perl5/site_perl/5.21.1' +sitelibexp='/usr/lib/perl5/site_perl/5.21.2' siteman1dir='/usr/share/man/man1' siteman1direxp='/usr/share/man/man1' siteman3dir='/usr/share/man/man3' @@ -950,7 +950,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='1' +subversion='2' sysman='/usr/share/man/man1' tail='' tar='' @@ -1035,8 +1035,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.21.1' -version_patchlevel_string='version 21 subversion 1' +version='5.21.2' +version_patchlevel_string='version 21 subversion 2' versiononly='undef' vi='' xlibpth='/usr/lib/386 /lib/386' @@ -1050,9 +1050,9 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=21 -PERL_SUBVERSION=1 +PERL_SUBVERSION=2 PERL_API_REVISION=5 PERL_API_VERSION=21 -PERL_API_SUBVERSION=1 +PERL_API_SUBVERSION=2 PERL_PATCHLEVEL= PERL_CONFIG_SH=true diff --git a/INSTALL b/INSTALL index b1c0722..5b27206 100644 --- a/INSTALL +++ b/INSTALL @@ -563,7 +563,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.21.1. +By default, Configure will use the following directories for 5.21.2. $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 @@ -2416,7 +2416,7 @@ http://www.chiark.greenend.org.uk/~sgtatham/bugs.html =head1 Coexistence with earlier versions of perl 5 -Perl 5.21.1 is not binary compatible with earlier versions of Perl. +Perl 5.21.2 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 (e.g. @@ -2490,9 +2490,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.21.1 + sh Configure -Dprefix=/opt/perl5.21.2 -and adding /opt/perl5.21.1/bin to the shell PATH variable. Such users +and adding /opt/perl5.21.2/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. @@ -2505,13 +2505,13 @@ seriously consider using a separate directory, since development subversions may not have all the compatibility wrinkles ironed out yet. -=head2 Upgrading from 5.21.0 or earlier +=head2 Upgrading from 5.21.1 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.21.1. If you find you do need to rebuild an extension with -5.21.1, you may safely do so without disturbing the older +used with 5.21.2. If you find you do need to rebuild an extension with +5.21.2, you may safely do so without disturbing the older installations. (See L<"Coexistence with earlier versions of perl 5"> above.) @@ -2544,15 +2544,15 @@ Firstly, the bare minimum to run this script print("$f\n"); } -in Linux with perl-5.21.1 is as follows (under $Config{prefix}): +in Linux with perl-5.21.2 is as follows (under $Config{prefix}): ./bin/perl - ./lib/perl5/5.21.1/strict.pm - ./lib/perl5/5.21.1/warnings.pm - ./lib/perl5/5.21.1/i686-linux/File/Glob.pm - ./lib/perl5/5.21.1/feature.pm - ./lib/perl5/5.21.1/XSLoader.pm - ./lib/perl5/5.21.1/i686-linux/auto/File/Glob/Glob.so + ./lib/perl5/5.21.2/strict.pm + ./lib/perl5/5.21.2/warnings.pm + ./lib/perl5/5.21.2/i686-linux/File/Glob.pm + ./lib/perl5/5.21.2/feature.pm + ./lib/perl5/5.21.2/XSLoader.pm + ./lib/perl5/5.21.2/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 i386 version. diff --git a/MANIFEST b/MANIFEST index 6cd6a75..d747c74 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1290,15 +1290,7 @@ cpan/IO-Compress/t/cz-06gzsetp.t IO::Compress cpan/IO-Compress/t/cz-08encoding.t IO::Compress cpan/IO-Compress/t/cz-14gzopen.t IO::Compress cpan/IO-Compress/t/globmapper.t IO::Compress -cpan/IO-Socket-IP/Build.PL IO::Socket::IP -cpan/IO-Socket-IP/Changes IO::Socket::IP cpan/IO-Socket-IP/lib/IO/Socket/IP.pm IO::Socket::IP -cpan/IO-Socket-IP/LICENSE IO::Socket::IP -cpan/IO-Socket-IP/Makefile.PL IO::Socket::IP -cpan/IO-Socket-IP/MANIFEST IO::Socket::IP -cpan/IO-Socket-IP/META.json IO::Socket::IP -cpan/IO-Socket-IP/META.yml IO::Socket::IP -cpan/IO-Socket-IP/README IO::Socket::IP cpan/IO-Socket-IP/t/00use.t IO::Socket::IP tests cpan/IO-Socket-IP/t/01local-client-v4.t IO::Socket::IP tests cpan/IO-Socket-IP/t/02local-server-v4.t IO::Socket::IP tests @@ -4447,6 +4439,7 @@ pod/perl5181delta.pod Perl changes in version 5.18.1 pod/perl5182delta.pod Perl changes in version 5.18.2 pod/perl5200delta.pod Perl changes in version 5.20.0 pod/perl5210delta.pod Perl changes in version 5.21.0 +pod/perl5211delta.pod Perl changes in version 5.21.1 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 @@ -5228,6 +5221,7 @@ t/porting/filenames.t Check the MANIFEST for filename portability. t/porting/FindExt.t Test win32/FindExt.pm t/porting/globvar.t Check that globvar.sym is sane t/porting/known_pod_issues.dat Data file for porting/podcheck.t +t/porting/libperl.t Check libperl.a sanity t/porting/maintainers.t Test that Porting/Maintainers.pl is up to date t/porting/manifest.t Test that this MANIFEST file is well formed t/porting/pending-author.t Check if any pending commit would break tests @@ -5325,6 +5319,7 @@ t/TEST The regression tester t/test.pl Simple testing library t/test_pl/can_isa_ok.t Tests for the simple testing library t/test_pl/_num_to_alpha.t Tests for the simple testing library +t/test_pl/plan_skip_all.t Tests for the simple testing library t/test_pl/tempfile.t Tests for the simple testing library t/thread_it.pl Run regression tests in a new thread t/uni/attrs.t See if Unicode attributes work diff --git a/META.json b/META.json index 4cd8b17..d824832 100644 --- a/META.json +++ b/META.json @@ -127,5 +127,5 @@ "url" : "http://perl5.git.perl.org/" } }, - "version" : "5.021001" + "version" : "5.021002" } diff --git a/META.yml b/META.yml index ce19e60..5abdd8d 100644 --- a/META.yml +++ b/META.yml @@ -114,4 +114,4 @@ resources: homepage: http://www.perl.org/ license: http://dev.perl.org/licenses/ repository: http://perl5.git.perl.org/ -version: '5.021001' +version: '5.021002' diff --git a/Makefile.SH b/Makefile.SH index 8438c4b..703e5f9 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -489,7 +489,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/perl5211delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod +perltoc_pod_prereqs = extra.pods pod/perl5212delta.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 @@ -999,9 +999,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/perl5211delta.pod: pod/perldelta.pod - $(RMS) pod/perl5211delta.pod - $(LNS) perldelta.pod pod/perl5211delta.pod +pod/perl5212delta.pod: pod/perldelta.pod + $(RMS) pod/perl5212delta.pod + $(LNS) perldelta.pod pod/perl5212delta.pod extra.pods: $(MINIPERL_EXE) -@test ! -f extra.pods || rm -f `cat extra.pods` @@ -1190,16 +1190,16 @@ manicheck: FORCE # DynaLoader may be needed for extensions that use Makefile.PL. $(DYNALOADER): $(MINIPERL_EXE) lib/buildcustomize.pl preplibrary FORCE $(nonxs_ext) - $(MINIPERL) make_ext.pl $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=static $(STATIC_LDFLAGS) + $(MINIPERL) make_ext.pl $@ $(MAKE_EXT_ARGS) MAKE="$(MAKE)" LIBPERL_A=$(LIBPERL) LINKTYPE=static $(STATIC_LDFLAGS) d_dummy $(dynamic_ext): $(MINIPERL_EXE) lib/buildcustomize.pl preplibrary makeppport $(DYNALOADER) FORCE $(PERLEXPORT) $(LIBPERL) - $(MINIPERL) make_ext.pl $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=dynamic + $(MINIPERL) make_ext.pl $@ $(MAKE_EXT_ARGS) MAKE="$(MAKE)" LIBPERL_A=$(LIBPERL) LINKTYPE=dynamic s_dummy $(static_ext): $(MINIPERL_EXE) lib/buildcustomize.pl preplibrary makeppport $(DYNALOADER) FORCE - $(MINIPERL) make_ext.pl $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=static $(STATIC_LDFLAGS) + $(MINIPERL) make_ext.pl $@ $(MAKE_EXT_ARGS) MAKE="$(MAKE)" LIBPERL_A=$(LIBPERL) LINKTYPE=static $(STATIC_LDFLAGS) n_dummy $(nonxs_ext): $(MINIPERL_EXE) lib/buildcustomize.pl preplibrary FORCE - $(MINIPERL) make_ext.pl $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) + $(MINIPERL) make_ext.pl $@ $(MAKE_EXT_ARGS) MAKE="$(MAKE)" LIBPERL_A=$(LIBPERL) !NO!SUBS! $spitshell >>$Makefile <>$Makefile <<'!NO!SUBS!' .PHONY: depend -depend: makedepend - sh ./makedepend MAKE=$(MAKE) cflags +depend: makedepend $(DTRACE_H) + sh ./makedepend MAKE="$(MAKE)" cflags .PHONY: test check test_prep test_prep_nodll test_prep_pre \ test_prep_reonly test_tty test-tty test_notty test-notty \ @@ -1445,7 +1445,7 @@ esac $spitshell >>$Makefile <<'!NO!SUBS!' test_prep_reonly: $(MINIPERL_EXE) $(PERL_EXE) $(dynamic_ext_re) $(TEST_PERL_DLL) - $(MINIPERL) make_ext.pl $(dynamic_ext_re) MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) LINKTYPE=dynamic + $(MINIPERL) make_ext.pl $(dynamic_ext_re) MAKE="$(MAKE)" LIBPERL_A=$(LIBPERL) LINKTYPE=dynamic cd t && (rm -f $(PERL_EXE); $(LNS) ../$(PERL_EXE) $(PERL_EXE)) !NO!SUBS! diff --git a/NetWare/Makefile b/NetWare/Makefile index 1f7293a..3c1ee2b 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.21.1 for NetWare" +MODULE_DESC = "Perl 5.21.2 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.21.1 +INST_VER = \5.21.2 # # Comment this out if you DON'T want your perl installation to have diff --git a/NetWare/config_H.wc b/NetWare/config_H.wc index 42f9fc0..204641a 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.21.1\\lib\\NetWare-x86-multi-thread" /**/ +#define ARCHLIB "c:\\perl\\5.21.2\\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.21.1\\bin\\NetWare-x86-multi-thread" /**/ -#define BIN_EXP "c:\\perl\\5.21.1\\bin\\NetWare-x86-multi-thread" /**/ +#define BIN "c:\\perl\\5.21.2\\bin\\NetWare-x86-multi-thread" /**/ +#define BIN_EXP "c:\\perl\\5.21.2\\bin\\NetWare-x86-multi-thread" /**/ /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, @@ -3051,7 +3051,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.21.1\\lib\\NetWare-x86-multi-thread" /**/ +#define SITEARCH "c:\\perl\\site\\5.21.2\\lib\\NetWare-x86-multi-thread" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -3074,7 +3074,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.21.1\\lib" /**/ +#define SITELIB "c:\\perl\\site\\5.21.2\\lib" /**/ /*#define SITELIB_EXP "" /**/ #define SITELIB_STEM "" /**/ diff --git a/Porting/Glossary b/Porting/Glossary index c58fb52..67e87d6 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -1746,6 +1746,9 @@ d_pthread_yield (d_pthread_y.U): symbol if the pthread_yield routine is available to yield the execution of the current thread. +d_ptrdiff_t (d_ptrdiff_t.U): + This symbol will be defined if the C compiler supports ptrdiff_t. + d_pwage (i_pwd.U): This variable conditionally defines PWAGE, which indicates that struct passwd contains pw_age. diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 6570126..d3d4793 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -401,7 +401,7 @@ use File::Glob qw(:case); }, 'experimental' => { - 'DISTRIBUTION' => 'LEONT/experimental-0.007.tar.gz', + 'DISTRIBUTION' => 'LEONT/experimental-0.008.tar.gz', 'FILES' => q[cpan/experimental], 'EXCLUDED' => [ qr{^t/release-.*\.t}, @@ -478,9 +478,9 @@ use File::Glob qw(:case); }, 'ExtUtils::Manifest' => { - 'DISTRIBUTION' => 'FLORA/ExtUtils-Manifest-1.63.tar.gz', + 'DISTRIBUTION' => 'BINGOS/ExtUtils-Manifest-1.64.tar.gz', 'FILES' => q[dist/ExtUtils-Manifest], - 'EXCLUDED' => [qr(t/release-.*\.t)], + 'EXCLUDED' => [qr(^xt/)], }, 'ExtUtils::ParseXS' => { @@ -622,7 +622,7 @@ use File::Glob qw(:case); }, 'IO::Socket::IP' => { - 'DISTRIBUTION' => 'PEVANS/IO-Socket-IP-0.29.tar.gz', + 'DISTRIBUTION' => 'PEVANS/IO-Socket-IP-0.31.tar.gz', 'FILES' => q[cpan/IO-Socket-IP], 'EXCLUDED' => [ qr{^examples/}, @@ -780,7 +780,7 @@ use File::Glob qw(:case); }, 'Module::CoreList' => { - 'DISTRIBUTION' => 'BINGOS/Module-CoreList-3.11.tar.gz', + 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.021001.tar.gz', 'FILES' => q[dist/Module-CoreList], }, @@ -913,7 +913,7 @@ use File::Glob qw(:case); }, 'Pod::Usage' => { - 'DISTRIBUTION' => 'MAREKR/Pod-Usage-1.63.tar.gz', + 'DISTRIBUTION' => 'MAREKR/Pod-Usage-1.64.tar.gz', 'FILES' => q[cpan/Pod-Usage], }, @@ -967,7 +967,7 @@ use File::Glob qw(:case); }, 'Storable' => { - 'DISTRIBUTION' => 'AMS/Storable-2.45.tar.gz', + 'DISTRIBUTION' => 'AMS/Storable-2.51.tar.gz', 'FILES' => q[dist/Storable], }, diff --git a/Porting/bump-perl-version b/Porting/bump-perl-version index 51a28a5..5654a57 100644 --- a/Porting/bump-perl-version +++ b/Porting/bump-perl-version @@ -223,6 +223,7 @@ my %SKIP_FILES = map { ($_ => 1) } qw( pp_ctl.c ); my @SKIP_DIRS = qw( + dist ext lib pod @@ -250,7 +251,7 @@ exit 0; sub do_scan { for my $file (@mani_files) { - next if grep $file =~ m{$_/}, @SKIP_DIRS; + next if grep $file =~ m{^$_/}, @SKIP_DIRS; if ($SKIP_FILES{$file}) { warn "(skipping $file)\n"; next; diff --git a/Porting/config.sh b/Porting/config.sh index 0a352e1..e66cab1 100644 --- a/Porting/config.sh +++ b/Porting/config.sh @@ -39,12 +39,12 @@ alignbytes='4' ansi2knr='' aphostname='/bin/hostname' api_revision='5' -api_subversion='1' +api_subversion='2' api_version='21' -api_versionstring='5.21.1' +api_versionstring='5.21.2' ar='ar' -archlib='/pro/lib/perl5/5.21.1/i686-linux-64int' -archlibexp='/pro/lib/perl5/5.21.1/i686-linux-64int' +archlib='/pro/lib/perl5/5.21.2/i686-linux-64int' +archlibexp='/pro/lib/perl5/5.21.2/i686-linux-64int' archname64='64int' archname='i686-linux-64int' archobjs='' @@ -752,7 +752,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.21.1/i686-linux-64int' +installarchlib='/pro/lib/perl5/5.21.2/i686-linux-64int' installbin='/pro/bin' installhtml1dir='' installhtml3dir='' @@ -760,13 +760,13 @@ installman1dir='/pro/local/man/man1' installman3dir='/pro/local/man/man3' installprefix='/pro' installprefixexp='/pro' -installprivlib='/pro/lib/perl5/5.21.1' +installprivlib='/pro/lib/perl5/5.21.2' installscript='/pro/bin' -installsitearch='/pro/lib/perl5/site_perl/5.21.1/i686-linux-64int' +installsitearch='/pro/lib/perl5/site_perl/5.21.2/i686-linux-64int' installsitebin='/pro/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='/pro/lib/perl5/site_perl/5.21.1' +installsitelib='/pro/lib/perl5/site_perl/5.21.2' installsiteman1dir='/pro/local/man/man1' installsiteman3dir='/pro/local/man/man3' installsitescript='/pro/bin' @@ -887,7 +887,7 @@ perl_patchlevel='' perl_static_inline='static __inline__' perladmin='hmbrand@cpan.org' perllibs='-lnsl -ldl -lm -lcrypt -lutil -lc' -perlpath='/pro/bin/perl5.21.1' +perlpath='/pro/bin/perl5.21.2' pg='pg' phostname='hostname' pidtype='pid_t' @@ -896,8 +896,8 @@ pmake='' pr='' prefix='/pro' prefixexp='/pro' -privlib='/pro/lib/perl5/5.21.1' -privlibexp='/pro/lib/perl5/5.21.1' +privlib='/pro/lib/perl5/5.21.2' +privlibexp='/pro/lib/perl5/5.21.2' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -963,17 +963,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.21.1/i686-linux-64int' -sitearchexp='/pro/lib/perl5/site_perl/5.21.1/i686-linux-64int' +sitearch='/pro/lib/perl5/site_perl/5.21.2/i686-linux-64int' +sitearchexp='/pro/lib/perl5/site_perl/5.21.2/i686-linux-64int' sitebin='/pro/bin' sitebinexp='/pro/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/pro/lib/perl5/site_perl/5.21.1' +sitelib='/pro/lib/perl5/site_perl/5.21.2' sitelib_stem='/pro/lib/perl5/site_perl' -sitelibexp='/pro/lib/perl5/site_perl/5.21.1' +sitelibexp='/pro/lib/perl5/site_perl/5.21.2' siteman1dir='/pro/local/man/man1' siteman1direxp='/pro/local/man/man1' siteman3dir='/pro/local/man/man3' @@ -999,7 +999,7 @@ src='.' ssizetype='ssize_t' st_ino_sign='1' st_ino_size='8' -startperl='#!/pro/bin/perl5.21.1' +startperl='#!/pro/bin/perl5.21.2' startsh='#!/bin/sh' static_ext=' ' stdchar='char' @@ -1012,7 +1012,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='1' +subversion='2' sysman='/usr/share/man/man1' sysroot='' tail='' @@ -1110,8 +1110,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.21.1' -version_patchlevel_string='version 21 subversion 1' +version='5.21.2' +version_patchlevel_string='version 21 subversion 2' versiononly='define' vi='' xlibpth='/usr/lib/386 /lib/386' @@ -1121,10 +1121,10 @@ zcat='' zip='zip' PERL_REVISION=5 PERL_VERSION=21 -PERL_SUBVERSION=1 +PERL_SUBVERSION=2 PERL_API_REVISION=5 PERL_API_VERSION=21 -PERL_API_SUBVERSION=1 +PERL_API_SUBVERSION=2 PERL_PATCHLEVEL='' PERL_CONFIG_SH=true : Variables propagated from previous config.sh file. diff --git a/Porting/config_H b/Porting/config_H index 9e99b54..2018e50 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.21.1/i686-linux-64int-ld" /**/ -#define ARCHLIB_EXP "/pro/lib/perl5/5.21.1/i686-linux-64int-ld" /**/ +#define ARCHLIB "/pro/lib/perl5/5.21.2/i686-linux-64int-ld" /**/ +#define ARCHLIB_EXP "/pro/lib/perl5/5.21.2/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.21.1" /**/ -#define PRIVLIB_EXP "/pro/lib/perl5/5.21.1" /**/ +#define PRIVLIB "/pro/lib/perl5/5.21.2" /**/ +#define PRIVLIB_EXP "/pro/lib/perl5/5.21.2" /**/ /* 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.21.1/i686-linux-64int-ld" /**/ -#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.21.1/i686-linux-64int-ld" /**/ +#define SITEARCH "/pro/lib/perl5/site_perl/5.21.2/i686-linux-64int-ld" /**/ +#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.21.2/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.21.1" /**/ -#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.21.1" /**/ +#define SITELIB "/pro/lib/perl5/site_perl/5.21.2" /**/ +#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.21.2" /**/ #define SITELIB_STEM "/pro/lib/perl5/site_perl" /**/ /* SSize_t: @@ -4326,7 +4326,7 @@ * script to make sure (one hopes) that it runs with perl and not * some shell. */ -#define STARTPERL "#!/pro/bin/perl5.21.1" /**/ +#define STARTPERL "#!/pro/bin/perl5.21.2" /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array diff --git a/Porting/corelist-perldelta.pl b/Porting/corelist-perldelta.pl index da02e7a..4301088 100755 --- a/Porting/corelist-perldelta.pl +++ b/Porting/corelist-perldelta.pl @@ -156,7 +156,7 @@ sub corelist_delta { }; my @unclaimedModules = qw/AnyDBM_File B B::Concise B::Deparse Benchmark Class::Struct Config::Extensions DB DBM_Filter Devel::Peek DirHandle DynaLoader English Errno ExtUtils::Embed ExtUtils::Miniperl ExtUtils::Typemaps ExtUtils::XSSymSet Fcntl File::Basename File::Compare File::Copy File::DosGlob File::Find File::Glob File::stat FileCache FileHandle FindBin GDBM_File Getopt::Std Hash::Util Hash::Util::FieldHash I18N::Langinfo IPC::Open3 NDBM_File ODBM_File Opcode PerlIO PerlIO::encoding PerlIO::mmap PerlIO::scalar PerlIO::via Pod::Functions Pod::Html POSIX SDBM_File SelectSaver Symbol Sys::Hostname Thread Tie::Array Tie::Handle Tie::Hash Tie::Hash::NamedCapture Tie::Memoize Tie::Scalar Tie::StdHandle Tie::SubstrHash Time::gmtime Time::localtime Time::tm Unicode::UCD UNIVERSAL User::grent User::pwent VMS::DCLsym VMS::Filespec VMS::Stdio XS::Typemap Win32CORE/; - my @unclaimedPragmata = qw/_charnames arybase attributes blib bytes charnames deprecate diagnostics encoding feature fields filetest inc::latest integer less locale mro open ops overload overloading re sigtrap sort strict subs utf8 vars vmsish/; + my @unclaimedPragmata = qw/arybase attributes blib bytes charnames deprecate diagnostics encoding feature fields filetest inc::latest integer less locale mro open ops overload overloading re sigtrap sort strict subs utf8 vars vmsish/; my @unclaimed = (@unclaimedModules, @unclaimedPragmata); my %distToModules = ( diff --git a/Porting/epigraphs.pod b/Porting/epigraphs.pod index 3b94edf..ffd4ab4 100644 --- a/Porting/epigraphs.pod +++ b/Porting/epigraphs.pod @@ -17,6 +17,21 @@ Consult your favorite dictionary for details. =head1 EPIGRAPHS +=head2 v5.21.1 - Robert Jordan, The Crossroads of Twilights, Book 10 of the Wheel of Time + +L + + We rode on the winds of the rising storm, + We ran to the sounds of the thunder. + We danced among the lightning bolts, + and tore the world asunder. + + -- Anonymous fragment of a poem believed + written near the end of the previous Age, + known by some as the Third Age. + Sometimes attributed to the Dragon + Reborn. + =head2 v5.21.0 - Friedrich von Schiller, The Song of the Bell L diff --git a/Porting/makerel b/Porting/makerel index 8739c29..e5d12c0 100755 --- a/Porting/makerel +++ b/Porting/makerel @@ -161,8 +161,18 @@ my @writables = qw( win32/config_H.vc uconfig.h ); -system("chmod u+w @writables") == 0 - or die "system: $!"; + +my $out = `chmod u+w @writables 2>&1`; +if ($? != 0) { + warn $out; + if ($out =~ /no such file/i) { + warn "Check that the files above still exist in the Perl core.\n"; + warn "If not, remove them from \@writables in Porting/makerel\n"; + } + exit 1; +} + +warn $out if $out; chdir ".." or die $!; diff --git a/Porting/perldelta_template.pod b/Porting/perldelta_template.pod index f302a3d..9c777b9 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.21.1..HEAD + perl Porting/acknowledgements.pl v5.21.2..HEAD =head1 Reporting Bugs diff --git a/Porting/release_managers_guide.pod b/Porting/release_managers_guide.pod index f61a79c..873b475 100644 --- a/Porting/release_managers_guide.pod +++ b/Porting/release_managers_guide.pod @@ -396,6 +396,10 @@ some of which need to be left unchanged. The line in F about "is binary incompatible with" requires a correct choice of earlier version to declare incompatibility with. +For the first RC release leading up to a BLEAD-FINAL release, update the +description of which releases are now "officially" supported in +F. + When doing a BLEAD-POINT or BLEAD-FINAL release, also make sure the C constants in F are in sync with the version you're releasing, unless you're absolutely sure the release you're about to @@ -609,7 +613,7 @@ Add a perldelta entry for the new Module::CoreList version. =head4 Update C<%Module::CoreList::released> and C -In addition, if this is a final release (rather than a release candidate): +For any release except an RC: =over 4 @@ -754,10 +758,9 @@ Add an entry to F with the release date, e.g.: David 5.10.1 2009-Aug-06 -Make sure that the correct pumpking is listed in the left-hand column, and -if this is the first release under the stewardship of a new pumpking, make -sure that his or her name is listed in the section entitled -C. +List yourself in the left-hand column, and if this is the first release +that you've ever done, make sure that your name is listed in the section +entitled C. I, also update the "SELECTED RELEASE SIZES" section with the output of @@ -849,8 +852,9 @@ Create a tarball. Use the C<-s> option to specify a suitable suffix for the tarball and directory name: $ cd root/of/perl/tree - $ make distclean + $ make distclean # make sure distclean works $ git clean -xdf # make sure perl and git agree on files + # git clean should not output anything! $ git status # and there's nothing lying around $ perl Porting/makerel -b -s RC1 # for a release candidate @@ -895,6 +899,9 @@ Check that basic configuration and tests work on each test machine: $ ./Configure -des && make all test + # Or for a development release: + $ ./Configure -Dusedevel -des && make all test + =head4 Run the test harness and install Check that the test harness and install work on each test machine: @@ -940,6 +947,9 @@ Bootstrap the CPAN client on the clean install: $ bin/cpan + # Or, perhaps: + $ bin/cpan5.xx.x + =head4 Install the Inline module with CPAN and test it Try installing a popular CPAN module that's reasonably complex and that diff --git a/Porting/release_schedule.pod b/Porting/release_schedule.pod index b8fa9b6..18f8fd3 100644 --- a/Porting/release_schedule.pod +++ b/Porting/release_schedule.pod @@ -8,7 +8,7 @@ release_schedule - Perl 5 release schedule This schedule lists the projected or historical development and release schedules for the next, current and previous stable versions -of Perl. Dates with all question marks will only be releases if +of Perl. Dates with two or more question marks will only be releases if deemed necessary by the Pumpking. =head2 Perl 5.20 @@ -41,8 +41,8 @@ you should reset the version numbers to the next blead series. =head2 Perl 5.21 - 2014-05-20 5.21.0 Ricardo Signes - 2014-06-20 5.21.1 Matthew Horsfall + 2014-05-20 5.21.0 ✓ Ricardo Signes + 2014-06-20 5.21.1 ✓ Matthew Horsfall 2014-07-20 5.21.2 Abigail 2014-08-20 5.21.3 Peter Martini 2014-09-20 5.21.4 Steve Hay diff --git a/Porting/todo.pod b/Porting/todo.pod index 774c49d..448ef59 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.21.1. +options would be nice for perl 5.21.2. =head2 Profile Perl - am I hot or not? @@ -555,14 +555,6 @@ ever creep back to libperl.a. Note, of course, that this will only tell whether B platform is using those naughty interfaces. -=head2 -D_FORTIFY_SOURCE=2 - -Recent glibcs support C<-D_FORTIFY_SOURCE=2> which gives -protection against various kinds of buffer overflow problems. -It should probably be used for compiling Perl whenever available, -Configure and/or hints files should be adjusted to probe for the -availability of these feature and enable it as appropriate. - =head2 Arenas for GPs? For MAGIC? C and C are both currently allocated by C. @@ -1176,7 +1168,7 @@ L =head1 Big projects Tasks that will get your name mentioned in the description of the "Highlights -of 5.21.1" +of 5.21.2" =head2 make ithreads more robust diff --git a/README.haiku b/README.haiku index de8df1b..bb51185 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.21.1/BePC-haiku/CORE/libperl.so . + cd /boot/common/lib; ln -s perl5/5.21.2/BePC-haiku/CORE/libperl.so . -Replace C<5.21.1> with your respective version of Perl. +Replace C<5.21.2> with your respective version of Perl. =head1 KNOWN PROBLEMS diff --git a/README.hpux b/README.hpux index 3fe142d..9d78a86 100644 --- a/README.hpux +++ b/README.hpux @@ -663,13 +663,24 @@ best fix is to patch the header to match: =head1 Redeclaration of "sendpath" with a different storage class specifier -The following compilation warnings seem to be unavoidable but harmless: +The following compilation warnings may happen in HP-UX releases +earlier than 11.31 but are harmless: cc: "/usr/include/sys/socket.h", line 535: warning 562: Redeclaration of "sendfile" with a different storage class specifier: "sendfile" will have internal linkage. cc: "/usr/include/sys/socket.h", line 536: warning 562: Redeclaration of "sendpath" with a different storage class specifier: "sendpath" will have internal linkage. They seem to be caused by broken system header files, and also other -open source projects are seeing them. +open source projects are seeing them. The following HP-UX patches +should make the warnings go away: + + CR JAGae12001: PHNE_27063 + Warning 562 on sys/socket.h due to redeclaration of prototypes + + CR JAGae16787: + Warning 562 from socket.h sendpath/sendfile -D_FILEFFSET_BITS=64 + + CR JAGae73470 (11.23) + ER: Compiling socket.h with cc -D_FILEFFSET_BITS=64 warning 267/562 =head1 Miscellaneous diff --git a/README.macosx b/README.macosx index 15bc4e8..51cede3 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.21.1.tar.gz - tar -xzf perl-5.21.1.tar.gz - cd perl-5.21.1 + curl -O http://www.cpan.org/src/perl-5.21.2.tar.gz + tar -xzf perl-5.21.2.tar.gz + cd perl-5.21.2 ./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.21.1 as of this writing) builds without changes +The latest Perl release (5.21.2 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 f72c16e..de27e85 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.21.1/ + unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.21.2/ 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 f6390e8..b584eac 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^.21^.1.tar + vmstar -xvf perl-5^.21^.2.tar Then set default to the top-level source directory like so: - set default [.perl-5^.21^.1] + set default [.perl-5^.21^.2] and proceed with configuration as described in the next section. diff --git a/autodoc.pl b/autodoc.pl index 0b7282d..6ba223e 100644 --- a/autodoc.pl +++ b/autodoc.pl @@ -15,12 +15,12 @@ # # This script is invoked as part of 'make all' # -# '=head1' are the only headings looked for. If the next line after the -# heading begins with a word character, it is considered to be the first line -# of documentation that applies to the heading itself. That is, it is output -# immediately after the heading, before the first function, and not indented. -# The next input line that is a pod directive terminates this heading-level -# documentation. +# '=head1' are the only headings looked for. If the first non-blank line after +# the heading begins with a word character, it is considered to be the first +# line of documentation that applies to the heading itself. That is, it is +# output immediately after the heading, before the first function, and not +# indented. The next input line that is a pod directive terminates this +# heading-level documentation. use strict; @@ -54,8 +54,12 @@ my $curheader = "Unknown section"; sub autodoc ($$) { # parse a file and extract documentation info my($fh,$file) = @_; my($in, $doc, $line, $header_doc); + + # Count lines easier + my $get_next_line = sub { $line++; return <$fh> }; + FUNC: - while (defined($in = <$fh>)) { + while (defined($in = $get_next_line->())) { if ($in =~ /^#\s*define\s+([A-Za-z_][A-Za-z_0-9]+)\(/ && ($file ne 'embed.h' || $file ne 'proto.h')) { $macro{$1} = $file; @@ -64,26 +68,31 @@ FUNC: if ($in=~ /^=head1 (.*)/) { $curheader = $1; - # If the next line begins with a word char, then is the start of - # heading-level documentation. - if (defined($doc = <$fh>)) { + # If the next non-space line begins with a word char, then it is + # the start of heading-ldevel documentation. + if (defined($doc = $get_next_line->())) { + # Skip over empty lines + while ($doc =~ /^\s+$/) { + if (! defined($doc = $get_next_line->())) { + next FUNC; + } + } + if ($doc !~ /^\w/) { $in = $doc; redo FUNC; } $header_doc = $doc; - $line++; # Continue getting the heading-level documentation until read # in any pod directive (or as a fail-safe, find a closing # comment to this pod in a C language file HDR_DOC: - while (defined($doc = <$fh>)) { + while (defined($doc = $get_next_line->())) { if ($doc =~ /^=\w/) { $in = $doc; redo FUNC; } - $line++; if ($doc =~ m:^\s*\*/$:) { warn "=cut missing? $file:$line:$doc";; @@ -94,15 +103,13 @@ HDR_DOC: } next FUNC; } - $line++; if ($in =~ /^=for\s+apidoc\s+(.*?)\s*\n/) { my $proto = $1; $proto = "||$proto" unless $proto =~ /\|/; my($flags, $ret, $name, @args) = split /\|/, $proto; my $docs = ""; DOC: - while (defined($doc = <$fh>)) { - $line++; + while (defined($doc = $get_next_line->())) { last DOC if $doc =~ /^=\w+/; if ($doc =~ m:^\*/$:) { warn "=cut missing? $file:$line:$doc";; diff --git a/av.c b/av.c index 0602525..49fef00 100644 --- a/av.c +++ b/av.c @@ -26,7 +26,6 @@ void Perl_av_reify(pTHX_ AV *av) { - dVAR; SSize_t key; PERL_ARGS_ASSERT_AV_REIFY; @@ -65,7 +64,6 @@ extended. void Perl_av_extend(pTHX_ AV *av, SSize_t key) { - dVAR; MAGIC *mg; PERL_ARGS_ASSERT_AV_EXTEND; @@ -87,8 +85,6 @@ void Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp, SV ***arrayp) { - dVAR; - PERL_ARGS_ASSERT_AV_EXTEND_GUTS; if (key > *maxp) { @@ -234,8 +230,6 @@ S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp) SV** Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval) { - dVAR; - PERL_ARGS_ASSERT_AV_FETCH; assert(SvTYPE(av) == SVt_PVAV); @@ -305,7 +299,6 @@ more information on how to use this function on tied arrays. SV** Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val) { - dVAR; SV** ary; PERL_ARGS_ASSERT_AV_STORE; @@ -441,7 +434,6 @@ Perl equivalent: C<@myarray = ();>. void Perl_av_clear(pTHX_ AV *av) { - dVAR; SSize_t extra; bool real; @@ -564,7 +556,6 @@ Perl equivalent: C. void Perl_av_push(pTHX_ AV *av, SV *val) { - dVAR; MAGIC *mg; PERL_ARGS_ASSERT_AV_PUSH; @@ -596,7 +587,6 @@ Perl equivalent: C SV * Perl_av_pop(pTHX_ AV *av) { - dVAR; SV *retval; MAGIC* mg; @@ -657,7 +647,6 @@ Perl equivalent: C void Perl_av_unshift(pTHX_ AV *av, SSize_t num) { - dVAR; SSize_t i; MAGIC* mg; @@ -722,7 +711,6 @@ Perl equivalent: C SV * Perl_av_shift(pTHX_ AV *av) { - dVAR; SV *retval; MAGIC* mg; @@ -799,7 +787,6 @@ the same as C. void Perl_av_fill(pTHX_ AV *av, SSize_t fill) { - dVAR; MAGIC *mg; PERL_ARGS_ASSERT_AV_FILL; @@ -851,7 +838,6 @@ C version. SV * Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags) { - dVAR; SV *sv; PERL_ARGS_ASSERT_AV_DELETE; @@ -929,7 +915,6 @@ Perl equivalent: C. bool Perl_av_exists(pTHX_ AV *av, SSize_t key) { - dVAR; PERL_ARGS_ASSERT_AV_EXISTS; assert(SvTYPE(av) == SVt_PVAV); @@ -983,7 +968,6 @@ Perl_av_exists(pTHX_ AV *av, SSize_t key) static MAGIC * S_get_aux_mg(pTHX_ AV *av) { - dVAR; MAGIC *mg; PERL_ARGS_ASSERT_GET_AUX_MG; diff --git a/caretx.c b/caretx.c index 047b9db..bf5ba85 100644 --- a/caretx.c +++ b/caretx.c @@ -52,7 +52,6 @@ void Perl_set_caret_X(pTHX) { - dVAR; GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */ if (tmpgv) { SV *const caret_x = GvSV(tmpgv); diff --git a/cflags.SH b/cflags.SH index dbd24b6..83fc3f8 100755 --- a/cflags.SH +++ b/cflags.SH @@ -132,7 +132,9 @@ int main(int argc, char *argv[]) { IV iv; Off_t t0a = 2; STRLEN t0b = 3; - int t0c = t0a == t0b; + int t0c = (STRLEN)t0a == t0b; + + printf("%s: %d\n", argv[0], argc); /* In FreeBSD 6.2 (and probably other releases too), with -Duse64bitint, perl will use atoll(3). However, that declaration is hidden in @@ -155,26 +157,50 @@ stdflags='' # (especially about things like long long, which are not in C89) will still be # valid if we now add flags like -std=c89. +pedantic='' +case "$gccansipedantic" in +define) pedantic='-pedantic' ;; +esac + case "$gccversion" in '') ;; [12]*) ;; # gcc versions 1 (gasp!) and 2 are not good for this. Intel*) ;; # # Is that you, Intel C++? -# XXX Note that -std=c89 without -pedantic is rather pointless. +# +# NOTE 1: the -std=c89 without -pedantic is a bit pointless. # Just -std=c89 means "if there is room for interpretation, -# interpret the C89 way." It does NOT mean "strict C89", -# you would need to add the -pedantic to get that. +# interpret the C89 way." It does NOT mean "strict C89" on its own. +# You need to add the -pedantic for that. To do this with Configure, +# do -Dgccansipedantic (note that the -ansi is included in any case, +# the option is a bit oddly named, for historical reasons.) +# +# NOTE 2: -pedantic necessitates adding a couple of flags: +# * -PERL_GCC_PEDANTIC so that the perl code can adapt: there's nothing +# added by gcc itself to indicate pedanticness. +# * -Wno-overlength-strings under -DDEBUGGING because quite many of +# the LEAVE_with_name() and assert() calls generate string literals +# longer then the ANSI minimum of 509 bytes. +# +# NOTE 3: the relative order of these options matters: +# -Wextra before -W, and -pedantic* before -Werror=d-a-s. # -# XXX If -pedantic (or -pedantic-errors!) is ever added, -# the -Werror=declaration-after-statement can be removed -# since "-std=c89 -pedantic" implies the -Werror=d-a-s. -*) for opt in -ansi -std=c89 -Wextra -W \ +*) for opt in -ansi -std=c89 $pedantic \ -Werror=declaration-after-statement \ + -Wextra -W \ -Wc++-compat -Wwrite-strings do case " $ccflags " in *" $opt "*) ;; # Skip if already there. *) rm -f _cflags$_exe - case "`$cc -DPERL_NO_INLINE_FUNCTIONS $ccflags $warn $stdflags $opt _cflags.c -o _cflags$_exe 2>&1`" in + flags="-DPERL_NO_INLINE_FUNCTIONS $ccflags $warn $stdflags $opt" + case "$opt" in + *-pedantic*) flags="$flags -DPERL_GCC_PEDANTIC" ;; + esac + # echo "opt = $opt, flags = $flags" + cmd="$cc $flags _cflags.c -o _cflags$_exe" + out="`$cmd 2>&1`" + # echo "$cmd --> $out" + case "$out" in *"unrecognized"*) ;; *"unknown"*) ;; *"implicit declaration"*) ;; # Was something useful hidden? @@ -195,10 +221,20 @@ Intel*) ;; # # Is that you, Intel C++? *-Wextra*) ;; *) echo "cflags.SH: Adding $opt." - warn="$warn opt" + warn="$warn $opt" ;; esac ;; + -Werror=declaration-after-statement) + # -pedantic* (with -std=c89) covers -Werror=d-a-s. + case "$stdflags$warn" in + *-std=c89*-pedantic*|*-pedantic*-std=c89*) ;; + *) + echo "cflags.SH: Adding $opt." + warn="$warn $opt" + ;; + esac + ;; *) echo "cflags.SH: Adding $opt." warn="$warn $opt" @@ -210,6 +246,22 @@ Intel*) ;; # # Is that you, Intel C++? esac ;; esac + case "$ccflags$warn" in + *-pedantic*) + overlength='' + case "$ccflags$optimize" in + *-DDEBUGGING*) overlength='-Wno-overlength-strings' ;; + esac + for opt2 in -DPERL_GCC_PEDANTIC $overlength + do + case "$ccflags$warn" in + *"$opt2"*) ;; + *) echo "cflags.SH: Adding $opt2 because of -pedantic." + warn="$warn $opt2" ;; + esac + done + ;; + esac done ;; esac @@ -218,38 +270,37 @@ rm -f _cflags.c _cflags$_exe case "$gccversion" in '') ;; *) - if [ "$gccansipedantic" = "" ]; then + case "$warn$ccflags" in + *-pedantic*) # If we have -Duse64bitint (or equivalent) in effect and the quadtype - # has become 'long long', gcc -pedantic becomes unbearable (moreso - # when combined with -Wall) because long long and LL and %lld|%Ld + # has become 'long long', gcc -pedantic* becomes unbearable + # (moreso when combined with -Wall) because long long and LL and %lld|%Ld # become warn-worthy. So let's drop the -pedantic in that case. - case "$quadtype:$sPRId64" in - "long long"*|*lld*|*Ld*) - echo "cflags.SH: Removing -pedantic and warn because of quadtype='long long'." - ccflags="`echo $ccflags|sed 's/-pedantic/ /'`" - warn="`echo $warn|sed 's/-pedantic/ /'`" - ;; - esac + # # Similarly, since 'long long' isn't part of C89, FreeBSD 6.2 headers # don't declare atoll() under -std=c89, but we need it. In general, # insisting on -std=c89 is inconsistent with insisting on using # 'long long'. So drop -std=c89 and -ansi as well if we're using # 'long long' as our main integral type. - case "$ivtype" in - "long long") - echo "cflags.SH: Removing -pedantic, -std=c89, and -ansi because of ivtype='long long'." - ccflags=`echo $ccflags|sed -e 's/-pedantic/ /' -e 's/-std=c89/ /' -e 's/-ansi/ /'` - warn=`echo $warn|sed -e 's/-pedantic/ /' -e 's/-ansi/ /'` - stdflags=`echo $stdflags|sed -e 's/-std=c89/ /'` - ;; + # + # usedtrace (DTrace) uses unportable features (dollars in identifiers, + # and gcc statement expressions), it is just easier to turn off pedantic. + remove='' + case "$quadtype:$ivtype:$sPRId64:$usedtrace" in + *"long long"*|*lld*|*Ld*) remove='long long' ;; + *) case "$usedtrace" in + define) remove='usedtrace' ;; + esac + ;; + esac + case "$remove" in + '') ;; + *) echo "cflags.SH: Removing -pedantic*, -std=c89, and -ansi because of $remove." + ccflags=`echo $ccflags|sed -e 's/-pedantic-errors/ /' -e 's/-pedantic/ /' -e 's/-std=c89/ /' -e 's/-ansi/ /' -e 's/-DPERL_GCC_PEDANTIC/ /'` + warn=`echo $warn|sed -e 's/-pedantic-errors/ /' -e 's/-pedantic/ /' -e 's/-ansi/ /' -e 's/-DPERL_GCC_PEDANTIC/ /'` + stdflags=`echo $stdflags|sed -e 's/-std=c89/ /'` + ;; esac - fi - # Using certain features (like the gcc statement expressions) - # requires knowing whether -pedantic has been specified. - case "$warn$ccflags" in - *-pedantic*) - echo "cflags.SH: Adding -DPERL_PEDANTIC because of -pedantic." - warn="$warn -DPERL_GCC_PEDANTIC" ;; esac ;; @@ -288,6 +339,12 @@ do esac done +echo "cflags.SH: cc = $cc" +echo "cflags.SH: ccflags = $ccflags" +echo "cflags.SH: stdflags = $stdflags" +echo "cflags.SH: optimize = $optimize" +echo "cflags.SH: warn = $warn" + # Code to set any extra flags here. extra='' diff --git a/config_h.SH b/config_h.SH index db150a6..c565a6c 100755 --- a/config_h.SH +++ b/config_h.SH @@ -1125,6 +1125,13 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #$d_attribute_unused HASATTRIBUTE_UNUSED /**/ #$d_attribute_warn_unused_result HASATTRIBUTE_WARN_UNUSED_RESULT /**/ +/* HAS_BACKTRACE: + * This symbol, if defined, indicates that the backtrace() routine is + * available to get a stack trace. The header must be + * included to use this routine. + */ +#$d_backtrace HAS_BACKTRACE /**/ + /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. @@ -1213,6 +1220,13 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #$d_ctime_r HAS_CTIME_R /**/ #define CTIME_R_PROTO $ctime_r_proto /**/ +/* HAS_DLADDR: + * This symbol, if defined, indicates that the dladdr() routine is + * available to query dynamic linker information for an address. + * The header must be included to use this routine. + */ +#$d_dladdr HAS_DLADDR /**/ + /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. @@ -2715,6 +2729,12 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #$d_dirnamlen DIRNAMLEN /**/ #define Direntry_t $direntrytype +/* I_EXECINFO: + * This symbol, if defined, indicates to the C program that it should + * include for backtrace() support. + */ +#$i_execinfo I_EXECINFO /**/ + /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . @@ -2853,6 +2873,26 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$i_sysuio I_SYSUIO /**/ +/* I_TERMIO: + * This symbol, if defined, indicates that the program should include + * rather than . There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/* I_TERMIOS: + * This symbol, if defined, indicates that the program should include + * the POSIX termios.h rather than sgtty.h or termio.h. + * There are also differences in the ioctl() calls that depend on the + * value of this symbol. + */ +/* I_SGTTY: + * This symbol, if defined, indicates that the program should include + * rather than . There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +#$i_termio I_TERMIO /**/ +#$i_termios I_TERMIOS /**/ +#$i_sgtty I_SGTTY /**/ + /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . @@ -3308,46 +3348,6 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #$d_vendorlib PERL_VENDORLIB_EXP "$vendorlibexp" /**/ #$d_vendorlib PERL_VENDORLIB_STEM "$vendorlib_stem" /**/ -/* HAS_BACKTRACE: - * This symbol, if defined, indicates that the backtrace() routine is - * available to get a stack trace. The header must be - * included to use this routine. - */ -#$d_backtrace HAS_BACKTRACE /**/ - -/* HAS_DLADDR: - * This symbol, if defined, indicates that the dladdr() routine is - * available to get a stack trace. The header must be - * included to use this routine. - */ -#$d_dladdr HAS_DLADDR /**/ - -/* I_EXECINFO: - * This symbol, if defined, indicates to the C program that it should - * include for backtrace() support. - */ -#$i_execinfo I_EXECINFO /**/ - -/* I_TERMIO: - * This symbol, if defined, indicates that the program should include - * rather than . There are also differences in - * the ioctl() calls that depend on the value of this symbol. - */ -/* I_TERMIOS: - * This symbol, if defined, indicates that the program should include - * the POSIX termios.h rather than sgtty.h or termio.h. - * There are also differences in the ioctl() calls that depend on the - * value of this symbol. - */ -/* I_SGTTY: - * This symbol, if defined, indicates that the program should include - * rather than . There are also differences in - * the ioctl() calls that depend on the value of this symbol. - */ -#$i_termio I_TERMIO /**/ -#$i_termios I_TERMIOS /**/ -#$i_sgtty I_SGTTY /**/ - /* USE_CROSS_COMPILE: * This symbol, if defined, indicates that Perl is being cross-compiled. */ @@ -3844,11 +3844,6 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_off64_t HAS_OFF64_T /**/ -/* HAS_PTRDIFF_T: - * This symbol will be defined if the C compiler supports ptrdiff_t. - */ -#$d_ptrdiff_t HAS_PTRDIFF_T /**/ - /* HAS_PRCTL: * This symbol, if defined, indicates that the prctl routine is * available to set process title. @@ -3881,6 +3876,11 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_pthread_attr_setscope HAS_PTHREAD_ATTR_SETSCOPE /**/ +/* HAS_PTRDIFF_T: + * This symbol will be defined if the C compiler supports ptrdiff_t. + */ +#$d_ptrdiff_t HAS_PTRDIFF_T /**/ + /* HAS_READV: * This symbol, if defined, indicates that the readv routine is * available to do gather reads. You will also need diff --git a/cpan/Digest-SHA/hints/hpux.pl b/cpan/Digest-SHA/hints/hpux.pl index e48609e..16e062f 100644 --- a/cpan/Digest-SHA/hints/hpux.pl +++ b/cpan/Digest-SHA/hints/hpux.pl @@ -1,15 +1,16 @@ # With +O2 this HP-UX cc compiler creates code which coredumps (Bus error) # when running t/woodbury.t, but dropping to +O1 seems to dodge that. +# Also gcc seems to have similar issues, so drop the opt also there. +# Modern HP-UX cc:s understand -On, so our task is easier. # -# This might turn out to be temporary, see: +# This was reported also at: # https://rt.cpan.org/Ticket/Display.html?id=96498 -if ($Config{cc} eq 'cc' && - $Config{archname} eq 'PA-RISC2.0' && - $Config{ccversion} =~ /^B\.11\.11\./) { - if (defined $self->{OPTIMIZE}) { - $self->{OPTIMIZE} =~ s/\+O[2-9]/+O1/; - $self->{OPTIMIZE} =~ s/ \+Onolimit//; - } else { - $self->{OPTIMIZE} = '+O1'; - } +# but the ticket was rejected since MSHELOR thinks Digest::SHA +# is doing nothing wrong. +if (defined $self->{OPTIMIZE}) { + $self->{OPTIMIZE} =~ s/ \+O[a-z_]+(?:=[\w,]+)?//; # Drop HP-UX +Onolimit etc. + # This will turn -O0 to -O1, but we will burn that bridge when we cross it. + $self->{OPTIMIZE} =~ s/[\+\-]O[0-9]*/-O1/; +} else { + $self->{OPTIMIZE} = '-O1'; } diff --git a/cpan/IO-Socket-IP/Build.PL b/cpan/IO-Socket-IP/Build.PL deleted file mode 100644 index bf77825..0000000 --- a/cpan/IO-Socket-IP/Build.PL +++ /dev/null @@ -1,22 +0,0 @@ -use strict; -use warnings; - -use Module::Build; - -my $build = Module::Build->new( - module_name => 'IO::Socket::IP', - requires => { - 'IO::Socket' => 0, - 'Socket' => '1.97', - }, - build_requires => { - 'Test::More' => '0.88', # done_testing - }, - auto_configure_requires => 0, # Don't add M::B to configure_requires - license => 'perl', - create_makefile_pl => 'traditional', - create_license => 1, - create_readme => 1, -); - -$build->create_build_script; diff --git a/cpan/IO-Socket-IP/Changes b/cpan/IO-Socket-IP/Changes deleted file mode 100644 index e647142..0000000 --- a/cpan/IO-Socket-IP/Changes +++ /dev/null @@ -1,193 +0,0 @@ -Revision history for IO-Socket-IP - -0.29 2014/02/24 16:06:29 - [BUGFIXES] - * Workaround for OSes that disobey AI_ADDRCONFIG and yield AIs on - families the kernel will not support anyway (e.g. HPUX) - * Workaround for OSes that lack getprotobyname() (e.g. Android) - -0.28 2014/02/10 16:17:59 - [CHANGES] - * Renamed internal _configure method to _io_socket_ip__configure to - avoid clashes with modules that try to subclass IO::Socket::INET - - [BUGFIXES] - * Disable AI_ADDRCONFIG during one-sided 'v6 tests as sometimes it - would otherwise fail - * Skip the SO_BROADCAST test on OSes that fail with EACCES (RT92502) - -0.27 2014/01/20 18:08:31 - [BUGFIXES] - * Apply a short timeout to unit tests that probe for internet - connectivity, in case of bad firewalls, etc... (Perl RT121037) - * Defend against machines with IN6ADDR_LOOPBACK not being "::1" in - unit tests, similar to the INADDR_LOOPBACK case (RT92295) - -0.26 2014/01/16 12:20:02 - [CHANGES] - * Set $VERSION in BEGIN block before 'use base' so that - Acme::Override::INET still works - * Various minor improvements to documentation - -0.25 2014/01/11 17:19:29 - [BUGFIXES] - * Allow both *Host with port and *Port arguments, letting port from - Host argument take precedence (INET compat) - * Ensure that a Host/Family-less constructor still constructs a - socket, by using gai()s AI_ADDRCONFIG hint - -0.24 2013/09/19 14:17:22 - [BUGFIXES] - * Defend against INADDR_LOOPBACK not being 127.0.0.1 on machines with - odd networking (e.g. FreeBSD jails) during unit testing - -0.23 2013/09/11 17:53:19 - [BUGFIXES] - * Check that kernel actually supports SO_REUSEPORT before - unit-testing it (RT86177) - -0.22 BUGFIXES: - * Always pass 'socktype' hint to getaddrinfo() in unit tests because - some OSes get upset without it - * Don't unit-test that sockaddr is updated with a local bind() on - SOCK_DGRAM sockets because some OSes don't - -0.21 CHANGES: - * Provide a downgrade method to turn an AF_INET-domain socket into a - real IO::Socket::INET instance - * Ensure that IO::Socket->new( Domain => ... ) definitely returns a - socket in the right family - -0.20 CHANGES: - * Skip the IPV6_V6ONLY tests on machines lacking that constant - * Avoid Socket::inet_pton() in unit tests as Strawberry lacks it - * Added ->join_addr - * Respect subclassing argument to ->accept - -0.19 CHANGES: - * More IO::Socket::INET compatibility fixes: - + Ensure ->connected is false after ->close - + Ensure that IO::Socket::IP->new(Family => $family) still creates - an unbound, unconnected socket filehandle - -0.18 CHANGES: - * Work around ->socktype being undef on IO::Socket versions before - 1.35 by fetching ->sockopt( SO_TYPE ) (RT81549) - - BUGFIXES: - * Fix test skip counts in t/21nonblocking-connect-internet.t (RT79393) - -0.17 CHANGES: - * Only pass AI_ADDRCONFIG as getaddrinfo() flag if no other flags - specified, so the caller can disable it if required. - - BUGFIXES: - * Don't count select() invocations during nonblocking unit test - because this is too unreliable and races with the kernel/TCP stack - -0.16 BUGFIXES: - * Don't ->close after all connect attempts fail, because - IO::Socket::INET doesn't do that - -0.15 BUGFIXES: - * (Hopefully) improved ->connect logic for better MSWin32 support - * Skip testing AI_NUMERICSERV on OSes that don't support it - -0.14 BUGFIXES: - * Second attempt at fixing test skip counts - -0.13 BUGFIXES: - * Updated test skip counts in unit tests so they match the number of - tests actually skipped - -0.12 CHANGES: - * Ensure that all instances have a defined fileno after construction, - even in non-blocking mode (RT77726) - -0.11 CHANGES: - * Ignore unrecognised constructor arguments rather than complaining - about their presence (RT77536) - * Call $self->connect during constructor because IO::Socket::SSL - relies on this to happen (RT77536) - -0.10 CHANGES: - * Allow specifying other getaddrinfo flags using GetAddrInfoFlags - constructor argument (RT75783) - * Provide a convenient hostname+port string splitting utility method - -0.09 CHANGES: - * Attempt to implement IPV6_V6ONLY sockopt wrapper - not all OSes can - disable it, so detect and skip those - * Provide ->sockaddr and ->peeraddr convenience accessors, same as - IO::Socket::INET (RT75071) - * Use new NIx_NOHOST and NIx_NOSERV flags to avoid redundant - getnameinfo() lookups when only one of host or service name is - required - * Ensure that errno gets set to EINVAL on getaddrinfo() failures - - BUGFIXES: - * Ignore existing-but-undefined constructor arguments - * Avoid locale-specific error message testing of $! - * Updates to unit tests for cygwin - -0.08 CHANGES: - * Depend on Socket 1.95 now a full dual-life release has been made - * Set the AI_ADDRCONFIG getaddrinfo hint - * Fix some spelling mistakes/typoes - * MSWin32 fixes: - + MSWin32 uses select() exceptfds rather than writefds to report - on nonblocking connect() failure - + MSWin32 uses EWOULDBLOCK rather than EINPROGRESS to indicate - nonblocking connect() - - BUGFIXES: - * Ensure ->socket protocol argument is always defined - * Bugfix for (e.g.) NetBSD, which gets upset at protocol hint without - socktype hint to getaddrinfo() - * Pass 'type' rather than 'proto' to constructor in t/11sockopts.t to - avoid MSWin32 test failures - * Localise $1/$2 to placate [perl #67962] - -0.07 CHANGES: - * Prepare for Socket::getaddrinfo() in core; prefer it to - Socket::GetAddrInfo::getaddrinfo() - * Implement Family constructor arg - * Optional registration with IO::Socket - * Documentation rewordings - * Bugfix to local socket connect tests - test using blocking rather - than nonblocking sockets to guarantee synchronous packet delivery - * Bugfix to t/04, t/05 - skip if unable to bind ::1 - -0.06 CHANGES: - * Implement nonblocking connect - * Implement LocalAddrInfo and PeerAddrInfo args - * Example of nonblocking usage, using Net::LibAsyncNS - -0.05 CHANGES: - * Implement combined ->bind and ->connect operations - * Accept "host:service" as *Addr args, and PeerAddr as sole - constructor argument - * Accept "name(port)" as service arguments - -0.04 CHANGES: - * Try to yield the most appropriate connect/bind/socket error - * Implement sockhost/peerhost methods to match ::INET, moved hostname - methods to sockhostname/peerhostname - - BUGFIXES: - * Work around IO::Socket bug where ->accept'ed sockets do not get - ->sockdomain or ->socktype - -0.03 CHANGES: - * Set $@ to raise error messages from constructor - - BUGFIXES: - * Correctly implement 'Type' constructor argument - * Test SO_BROADCAST on udp instead of tcp as some OSes forbid it - -0.02 BUGFIXES: - * Not all OSes return true sockopts as 1; test simply for non-zero - * Gracefully skip IPv6 tests if Socket6 unavailable - -0.01 First version, released on an unsuspecting world. - diff --git a/cpan/IO-Socket-IP/LICENSE b/cpan/IO-Socket-IP/LICENSE deleted file mode 100644 index 0c0af11..0000000 --- a/cpan/IO-Socket-IP/LICENSE +++ /dev/null @@ -1,379 +0,0 @@ -This software is copyright (c) 2014 by Paul Evans . - -This is free software; you can redistribute it and/or modify it under -the same terms as the Perl 5 programming language system itself. - -Terms of the Perl programming language system itself - -a) the GNU General Public License as published by the Free - Software Foundation; either version 1, or (at your option) any - later version, or -b) the "Artistic License" - ---- The GNU General Public License, Version 1, February 1989 --- - -This software is Copyright (c) 2014 by Paul Evans . - -This is free software, licensed under: - - The GNU General Public License, Version 1, February 1989 - - GNU GENERAL PUBLIC LICENSE - Version 1, February 1989 - - Copyright (C) 1989 Free Software Foundation, Inc. - 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA - - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The license agreements of most software companies try to keep users -at the mercy of those companies. By contrast, our General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. The -General Public License applies to the Free Software Foundation's -software and to any other program whose authors commit to using it. -You can use it for your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Specifically, the General Public License is designed to make -sure that you have the freedom to give away or sell copies of free -software, that you receive source code or can get it if you want it, -that you can change the software or use pieces of it in new free -programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of a such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must tell them their rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License Agreement applies to any program or other work which -contains a notice placed by the copyright holder saying it may be -distributed under the terms of this General Public License. The -"Program", below, refers to any such program or work, and a "work based -on the Program" means either the Program or any work containing the -Program or a portion of it, either verbatim or with modifications. Each -licensee is addressed as "you". - - 1. You may copy and distribute verbatim copies of the Program's source -code as you receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice and -disclaimer of warranty; keep intact all the notices that refer to this -General Public License and to the absence of any warranty; and give any -other recipients of the Program a copy of this General Public License -along with the Program. You may charge a fee for the physical act of -transferring a copy. - - 2. You may modify your copy or copies of the Program or any portion of -it, and copy and distribute such modifications under the terms of Paragraph -1 above, provided that you also do the following: - - a) cause the modified files to carry prominent notices stating that - you changed the files and the date of any change; and - - b) cause the whole of any work that you distribute or publish, that - in whole or in part contains the Program or any part thereof, either - with or without modifications, to be licensed at no charge to all - third parties under the terms of this General Public License (except - that you may choose to grant warranty protection to some or all - third parties, at your option). - - c) If the modified program normally reads commands interactively when - run, you must cause it, when started running for such interactive use - in the simplest and most usual way, to print or display an - announcement including an appropriate copyright notice and a notice - that there is no warranty (or else, saying that you provide a - warranty) and that users may redistribute the program under these - conditions, and telling the user how to view a copy of this General - Public License. - - d) You may charge a fee for the physical act of transferring a - copy, and you may at your option offer warranty protection in - exchange for a fee. - -Mere aggregation of another independent work with the Program (or its -derivative) on a volume of a storage or distribution medium does not bring -the other work under the scope of these terms. - - 3. You may copy and distribute the Program (or a portion or derivative of -it, under Paragraph 2) in object code or executable form under the terms of -Paragraphs 1 and 2 above provided that you also do one of the following: - - a) accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of - Paragraphs 1 and 2 above; or, - - b) accompany it with a written offer, valid for at least three - years, to give any third party free (except for a nominal charge - for the cost of distribution) a complete machine-readable copy of the - corresponding source code, to be distributed under the terms of - Paragraphs 1 and 2 above; or, - - c) accompany it with the information you received as to where the - corresponding source code may be obtained. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form alone.) - -Source code for a work means the preferred form of the work for making -modifications to it. For an executable file, complete source code means -all the source code for all modules it contains; but, as a special -exception, it need not include source code for modules which are standard -libraries that accompany the operating system on which the executable -file runs, or for standard header files or definitions files that -accompany that operating system. - - 4. You may not copy, modify, sublicense, distribute or transfer the -Program except as expressly provided under this General Public License. -Any attempt otherwise to copy, modify, sublicense, distribute or transfer -the Program is void, and will automatically terminate your rights to use -the Program under this License. However, parties who have received -copies, or rights to use copies, from you under this General Public -License will not have their licenses terminated so long as such parties -remain in full compliance. - - 5. By copying, distributing or modifying the Program (or any work based -on the Program) you indicate your acceptance of this license to do so, -and all its terms and conditions. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the original -licensor to copy, distribute or modify the Program subject to these -terms and conditions. You may not impose any further restrictions on the -recipients' exercise of the rights granted herein. - - 7. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of the license which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -the license, you may choose any version ever published by the Free Software -Foundation. - - 8. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - Appendix: How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to humanity, the best way to achieve this is to make it -free software which everyone can redistribute and change under these -terms. - - To do so, attach the following notices to the program. It is safest to -attach them to the start of each source file to most effectively convey -the exclusion of warranty; and each file should have at least the -"copyright" line and a pointer to where the full notice is found. - - - Copyright (C) 19yy - - 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 1, 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 - - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) 19xx name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the -appropriate parts of the General Public License. Of course, the -commands you use may be called something other than `show w' and `show -c'; they could even be mouse-clicks or menu items--whatever suits your -program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the - program `Gnomovision' (a program to direct compilers to make passes - at assemblers) written by James Hacker. - - , 1 April 1989 - Ty Coon, President of Vice - -That's all there is to it! - - ---- The Artistic License 1.0 --- - -This software is Copyright (c) 2014 by Paul Evans . - -This is free software, licensed under: - - The Artistic License 1.0 - -The Artistic License - -Preamble - -The intent of this document is to state the conditions under which a Package -may be copied, such that the Copyright Holder maintains some semblance of -artistic control over the development of the package, while giving the users of -the package the right to use and distribute the Package in a more-or-less -customary fashion, plus the right to make reasonable modifications. - -Definitions: - - - "Package" refers to the collection of files distributed by the Copyright - Holder, and derivatives of that collection of files created through - textual modification. - - "Standard Version" refers to such a Package if it has not been modified, - or has been modified in accordance with the wishes of the Copyright - Holder. - - "Copyright Holder" is whoever is named in the copyright or copyrights for - the package. - - "You" is you, if you're thinking about copying or distributing this Package. - - "Reasonable copying fee" is whatever you can justify on the basis of media - cost, duplication charges, time of people involved, and so on. (You will - not be required to justify it to the Copyright Holder, but only to the - computing community at large as a market that must bear the fee.) - - "Freely Available" means that no fee is charged for the item itself, though - there may be fees involved in handling the item. It also means that - recipients of the item may redistribute it under the same conditions they - received it. - -1. You may make and give away verbatim copies of the source form of the -Standard Version of this Package without restriction, provided that you -duplicate all of the original copyright notices and associated disclaimers. - -2. You may apply bug fixes, portability fixes and other modifications derived -from the Public Domain or from the Copyright Holder. A Package modified in such -a way shall still be considered the Standard Version. - -3. You may otherwise modify your copy of this Package in any way, provided that -you insert a prominent notice in each changed file stating how and when you -changed that file, and provided that you do at least ONE of the following: - - a) place your modifications in the Public Domain or otherwise make them - Freely Available, such as by posting said modifications to Usenet or an - equivalent medium, or placing the modifications on a major archive site - such as ftp.uu.net, or by allowing the Copyright Holder to include your - modifications in the Standard Version of the Package. - - b) use the modified Package only within your corporation or organization. - - c) rename any non-standard executables so the names do not conflict with - standard executables, which must also be provided, and provide a separate - manual page for each non-standard executable that clearly documents how it - differs from the Standard Version. - - d) make other distribution arrangements with the Copyright Holder. - -4. You may distribute the programs of this Package in object code or executable -form, provided that you do at least ONE of the following: - - a) distribute a Standard Version of the executables and library files, - together with instructions (in the manual page or equivalent) on where to - get the Standard Version. - - b) accompany the distribution with the machine-readable source of the Package - with your modifications. - - c) accompany any non-standard executables with their corresponding Standard - Version executables, giving the non-standard executables non-standard - names, and clearly documenting the differences in manual pages (or - equivalent), together with instructions on where to get the Standard - Version. - - d) make other distribution arrangements with the Copyright Holder. - -5. You may charge a reasonable copying fee for any distribution of this -Package. You may charge any fee you choose for support of this Package. You -may not charge a fee for this Package itself. However, you may distribute this -Package in aggregate with other (possibly commercial) programs as part of a -larger (possibly commercial) software distribution provided that you do not -advertise this Package as a product of your own. - -6. The scripts and library files supplied as input to or produced as output -from the programs of this Package do not automatically fall under the copyright -of this Package, but belong to whomever generated them, and may be sold -commercially, and may be aggregated with this Package. - -7. C or perl subroutines supplied by you and linked into this Package shall not -be considered part of this Package. - -8. The name of the Copyright Holder may not be used to endorse or promote -products derived from this software without specific prior written permission. - -9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED -WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF -MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. - -The End - diff --git a/cpan/IO-Socket-IP/MANIFEST b/cpan/IO-Socket-IP/MANIFEST deleted file mode 100644 index 7822de7..0000000 --- a/cpan/IO-Socket-IP/MANIFEST +++ /dev/null @@ -1,33 +0,0 @@ -Build.PL -Changes -examples/connect.pl -examples/nonblocking_libasyncns.pl -lib/IO/Socket/IP.pm -LICENSE -Makefile.PL -MANIFEST This list of files -META.json -META.yml -README -t/00use.t -t/01local-client-v4.t -t/02local-server-v4.t -t/03local-cross-v4.t -t/04local-client-v6.t -t/05local-server-v6.t -t/06local-cross-v6.t -t/10args.t -t/11sockopts.t -t/12port-fallback.t -t/13addrinfo.t -t/14fileno.t -t/15io-socket.t -t/16v6only.t -t/17gai-flags.t -t/18fdopen.t -t/19no-addrs.t -t/20subclass.t -t/21as-inet.t -t/30nonblocking-connect.t -t/31nonblocking-connect-internet.t -t/99pod.t diff --git a/cpan/IO-Socket-IP/META.json b/cpan/IO-Socket-IP/META.json deleted file mode 100644 index b6e4390..0000000 --- a/cpan/IO-Socket-IP/META.json +++ /dev/null @@ -1,42 +0,0 @@ -{ - "abstract" : "Family-neutral IP socket supporting both IPv4 and IPv6", - "author" : [ - "Paul Evans " - ], - "dynamic_config" : 1, - "generated_by" : "Module::Build version 0.4204", - "license" : [ - "perl_5" - ], - "meta-spec" : { - "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", - "version" : "2" - }, - "name" : "IO-Socket-IP", - "prereqs" : { - "build" : { - "requires" : { - "Test::More" : "0.88" - } - }, - "runtime" : { - "requires" : { - "IO::Socket" : "0", - "Socket" : "1.97" - } - } - }, - "provides" : { - "IO::Socket::IP" : { - "file" : "lib/IO/Socket/IP.pm", - "version" : "0.29" - } - }, - "release_status" : "stable", - "resources" : { - "license" : [ - "http://dev.perl.org/licenses/" - ] - }, - "version" : "0.29" -} diff --git a/cpan/IO-Socket-IP/META.yml b/cpan/IO-Socket-IP/META.yml deleted file mode 100644 index f860cc0..0000000 --- a/cpan/IO-Socket-IP/META.yml +++ /dev/null @@ -1,23 +0,0 @@ ---- -abstract: 'Family-neutral IP socket supporting both IPv4 and IPv6' -author: - - 'Paul Evans ' -build_requires: - Test::More: '0.88' -dynamic_config: 1 -generated_by: 'Module::Build version 0.4204, CPAN::Meta::Converter version 2.133380' -license: perl -meta-spec: - url: http://module-build.sourceforge.net/META-spec-v1.4.html - version: '1.4' -name: IO-Socket-IP -provides: - IO::Socket::IP: - file: lib/IO/Socket/IP.pm - version: '0.29' -requires: - IO::Socket: '0' - Socket: '1.97' -resources: - license: http://dev.perl.org/licenses/ -version: '0.29' diff --git a/cpan/IO-Socket-IP/Makefile.PL b/cpan/IO-Socket-IP/Makefile.PL deleted file mode 100644 index 796159d..0000000 --- a/cpan/IO-Socket-IP/Makefile.PL +++ /dev/null @@ -1,16 +0,0 @@ -# Note: this file was auto-generated by Module::Build::Compat version 0.4204 -use ExtUtils::MakeMaker; -WriteMakefile -( - 'NAME' => 'IO::Socket::IP', - 'VERSION_FROM' => 'lib/IO/Socket/IP.pm', - 'PREREQ_PM' => { - 'IO::Socket' => 0, - 'Socket' => '1.97', - 'Test::More' => '0.88' - }, - 'INSTALLDIRS' => 'site', - 'EXE_FILES' => [], - 'PL_FILES' => {} -) -; diff --git a/cpan/IO-Socket-IP/README b/cpan/IO-Socket-IP/README deleted file mode 100644 index b3f50cf..0000000 --- a/cpan/IO-Socket-IP/README +++ /dev/null @@ -1,416 +0,0 @@ -NAME - `IO::Socket::IP' - Family-neutral IP socket supporting both IPv4 and - IPv6 - -SYNOPSIS - use IO::Socket::IP; - - my $sock = IO::Socket::IP->new( - PeerHost => "www.google.com", - PeerPort => "http", - Type => SOCK_STREAM, - ) or die "Cannot construct socket - $@"; - - my $familyname = ( $sock->sockdomain == PF_INET6 ) ? "IPv6" : - ( $sock->sockdomain == PF_INET ) ? "IPv4" : - "unknown"; - - printf "Connected to google via %s\n", $familyname; - -DESCRIPTION - This module provides a protocol-independent way to use IPv4 and IPv6 - sockets, intended as a replacement for IO::Socket::INET. Most - constructor arguments and methods are provided in a backward-compatible - way. For a list of known differences, see the `IO::Socket::INET' - INCOMPATIBILITES section below. - - It uses the `getaddrinfo(3)' function to convert hostnames and service - names or port numbers into sets of possible addresses to connect to or - listen on. This allows it to work for IPv6 where the system supports it, - while still falling back to IPv4-only on systems which don't. - -REPLACING `IO::Socket' DEFAULT BEHAVIOUR - By placing `-register' in the import list, IO::Socket uses - `IO::Socket::IP' rather than `IO::Socket::INET' as the class that - handles `PF_INET'. `IO::Socket' will also use `IO::Socket::IP' rather - than `IO::Socket::INET6' to handle `PF_INET6', provided that the - `AF_INET6' constant is available. - - Changing `IO::Socket''s default behaviour means that calling the - `IO::Socket' constructor with either `PF_INET' or `PF_INET6' as the - `Domain' parameter will yield an `IO::Socket::IP' object. - - use IO::Socket::IP -register; - - my $sock = IO::Socket->new( - Domain => PF_INET6, - LocalHost => "::1", - Listen => 1, - ) or die "Cannot create socket - $@\n"; - - print "Created a socket of type " . ref($sock) . "\n"; - - Note that `-register' is a global setting that applies to the entire - program; it cannot be applied only for certain callers, removed, or - limited by lexical scope. - -CONSTRUCTORS - $sock = IO::Socket::IP->new( %args ) - Creates a new `IO::Socket::IP' object, containing a newly created socket - handle according to the named arguments passed. The recognised arguments - are: - - PeerHost => STRING - PeerService => STRING - Hostname and service name for the peer to `connect()' to. The - service name may be given as a port number, as a decimal string. - - PeerAddr => STRING - PeerPort => STRING - For symmetry with the accessor methods and compatibility with - `IO::Socket::INET', these are accepted as synonyms for - `PeerHost' and `PeerService' respectively. - - PeerAddrInfo => ARRAY - Alternate form of specifying the peer to `connect()' to. This - should be an array of the form returned by - `Socket::getaddrinfo'. - - This parameter takes precedence over the `Peer*', `Family', - `Type' and `Proto' arguments. - - LocalHost => STRING - LocalService => STRING - Hostname and service name for the local address to `bind()' to. - - LocalAddr => STRING - LocalPort => STRING - For symmetry with the accessor methods and compatibility with - `IO::Socket::INET', these are accepted as synonyms for - `LocalHost' and `LocalService' respectively. - - LocalAddrInfo => ARRAY - Alternate form of specifying the local address to `bind()' to. - This should be an array of the form returned by - `Socket::getaddrinfo'. - - This parameter takes precedence over the `Local*', `Family', - `Type' and `Proto' arguments. - - Family => INT - The address family to pass to `getaddrinfo' (e.g. `AF_INET', - `AF_INET6'). Normally this will be left undefined, and - `getaddrinfo' will search using any address family supported by - the system. - - Type => INT - The socket type to pass to `getaddrinfo' (e.g. `SOCK_STREAM', - `SOCK_DGRAM'). Normally defined by the caller; if left undefined - `getaddrinfo' may attempt to infer the type from the service - name. - - Proto => STRING or INT - The IP protocol to use for the socket (e.g. `'tcp'', - `IPPROTO_TCP', `'udp'',`IPPROTO_UDP'). Normally this will be - left undefined, and either `getaddrinfo' or the kernel will - choose an appropriate value. May be given either in string name - or numeric form. - - GetAddrInfoFlags => INT - More flags to pass to the `getaddrinfo()' function. If not - supplied, a default of `AI_ADDRCONFIG' will be used. - - These flags will be combined with `AI_PASSIVE' if the `Listen' - argument is given. For more information see the documentation - about `getaddrinfo()' in the Socket module. - - Listen => INT - If defined, puts the socket into listening mode where new - connections can be accepted using the `accept' method. The value - given is used as the `listen(2)' queue size. - - ReuseAddr => BOOL - If true, set the `SO_REUSEADDR' sockopt - - ReusePort => BOOL - If true, set the `SO_REUSEPORT' sockopt (not all OSes implement - this sockopt) - - Broadcast => BOOL - If true, set the `SO_BROADCAST' sockopt - - V6Only => BOOL - If defined, set the `IPV6_V6ONLY' sockopt when creating - `PF_INET6' sockets to the given value. If true, a listening-mode - socket will only listen on the `AF_INET6' addresses; if false it - will also accept connections from `AF_INET' addresses. - - If not defined, the socket option will not be changed, and - default value set by the operating system will apply. For - repeatable behaviour across platforms it is recommended this - value always be defined for listening-mode sockets. - - Note that not all platforms support disabling this option. Some, - at least OpenBSD and MirBSD, will fail with `EINVAL' if you - attempt to disable it. To determine whether it is possible to - disable, you may use the class method - - if( IO::Socket::IP->CAN_DISABLE_V6ONLY ) { - ... - } - else { - ... - } - - If your platform does not support disabling this option but you - still want to listen for both `AF_INET' and `AF_INET6' - connections you will have to create two listening sockets, one - bound to each protocol. - - MultiHomed - This `IO::Socket::INET'-style argument is ignored, except if it - is defined but false. See the `IO::Socket::INET' - INCOMPATIBILITES section below. - - However, the behaviour it enables is always performed by - `IO::Socket::IP'. - - Blocking => BOOL - If defined but false, the socket will be set to non-blocking - mode. Otherwise it will default to blocking mode. See the - NON-BLOCKING section below for more detail. - - If neither `Type' nor `Proto' hints are provided, a default of - `SOCK_STREAM' and `IPPROTO_TCP' respectively will be set, to maintain - compatibility with `IO::Socket::INET'. Other named arguments that are - not recognised are ignored. - - If neither `Family' nor any hosts or addresses are passed, nor any - `*AddrInfo', then the constructor has no information on which to decide - a socket family to create. In this case, it performs a `getaddinfo' call - with the `AI_ADDRCONFIG' flag, no host name, and a service name of - `"0"', and uses the family of the first returned result. - - If the constructor fails, it will set `$@' to an appropriate error - message; this may be from `$!' or it may be some other string; not every - failure necessarily has an associated `errno' value. - - $sock = IO::Socket::IP->new( $peeraddr ) - As a special case, if the constructor is passed a single argument (as - opposed to an even-sized list of key/value pairs), it is taken to be the - value of the `PeerAddr' parameter. This is parsed in the same way, - according to the behaviour given in the `PeerHost' AND `LocalHost' - PARSING section below. - -METHODS - As well as the following methods, this class inherits all the methods in - IO::Socket and IO::Handle. - - ( $host, $service ) = $sock->sockhost_service( $numeric ) - Returns the hostname and service name of the local address (that is, the - socket address given by the `sockname' method). - - If `$numeric' is true, these will be given in numeric form rather than - being resolved into names. - - The following four convenience wrappers may be used to obtain one of the - two values returned here. If both host and service names are required, - this method is preferable to the following wrappers, because it will - call `getnameinfo(3)' only once. - - $addr = $sock->sockhost - Return the numeric form of the local address as a textual representation - - $port = $sock->sockport - Return the numeric form of the local port number - - $host = $sock->sockhostname - Return the resolved name of the local address - - $service = $sock->sockservice - Return the resolved name of the local port number - - $addr = $sock->sockaddr - Return the local address as a binary octet string - - ( $host, $service ) = $sock->peerhost_service( $numeric ) - Returns the hostname and service name of the peer address (that is, the - socket address given by the `peername' method), similar to the - `sockhost_service' method. - - The following four convenience wrappers may be used to obtain one of the - two values returned here. If both host and service names are required, - this method is preferable to the following wrappers, because it will - call `getnameinfo(3)' only once. - - $addr = $sock->peerhost - Return the numeric form of the peer address as a textual representation - - $port = $sock->peerport - Return the numeric form of the peer port number - - $host = $sock->peerhostname - Return the resolved name of the peer address - - $service = $sock->peerservice - Return the resolved name of the peer port number - - $addr = $peer->peeraddr - Return the peer address as a binary octet string - - $inet = $sock->as_inet - Returns a new IO::Socket::INET instance wrapping the same filehandle. - This may be useful in cases where it is required, for - backward-compatibility, to have a real object of `IO::Socket::INET' type - instead of `IO::Socket::IP'. The new object will wrap the same - underlying socket filehandle as the original, so care should be taken - not to continue to use both objects concurrently. Ideally the original - `$sock' should be discarded after this method is called. - - This method checks that the socket domain is `PF_INET' and will throw an - exception if it isn't. - -NON-BLOCKING - If the constructor is passed a defined but false value for the - `Blocking' argument then the socket is put into non-blocking mode. When - in non-blocking mode, the socket will not be set up by the time the - constructor returns, because the underlying `connect(2)' syscall would - otherwise have to block. - - The non-blocking behaviour is an extension of the `IO::Socket::INET' - API, unique to `IO::Socket::IP', because the former does not support - multi-homed non-blocking connect. - - When using non-blocking mode, the caller must repeatedly check for - writeability on the filehandle (for instance using `select' or - `IO::Poll'). Each time the filehandle is ready to write, the `connect' - method must be called, with no arguments. Note that some operating - systems, most notably `MSWin32' do not report a `connect()' failure - using write-ready; so you must also `select()' for exceptional status. - - While `connect' returns false, the value of `$!' indicates whether it - should be tried again (by being set to the value `EINPROGRESS', or - `EWOULDBLOCK' on MSWin32), or whether a permanent error has occurred - (e.g. `ECONNREFUSED'). - - Once the socket has been connected to the peer, `connect' will return - true and the socket will now be ready to use. - - Note that calls to the platform's underlying `getaddrinfo(3)' function - may block. If `IO::Socket::IP' has to perform this lookup, the - constructor will block even when in non-blocking mode. - - To avoid this blocking behaviour, the caller should pass in the result - of such a lookup using the `PeerAddrInfo' or `LocalAddrInfo' arguments. - This can be achieved by using Net::LibAsyncNS, or the `getaddrinfo(3)' - function can be called in a child process. - - use IO::Socket::IP; - use Errno qw( EINPROGRESS EWOULDBLOCK ); - - my @peeraddrinfo = ... # Caller must obtain the getaddinfo result here - - my $socket = IO::Socket::IP->new( - PeerAddrInfo => \@peeraddrinfo, - Blocking => 0, - ) or die "Cannot construct socket - $@"; - - while( !$socket->connect and ( $! == EINPROGRESS || $! == EWOULDBLOCK ) ) { - my $wvec = ''; - vec( $wvec, fileno $socket, 1 ) = 1; - my $evec = ''; - vec( $evec, fileno $socket, 1 ) = 1; - - select( undef, $wvec, $evec, undef ) or die "Cannot select - $!"; - } - - die "Cannot connect - $!" if $!; - - ... - - The example above uses `select()', but any similar mechanism should work - analogously. `IO::Socket::IP' takes care when creating new socket - filehandles to preserve the actual file descriptor number, so such - techniques as `poll' or `epoll' should be transparent to its - reallocation of a different socket underneath, perhaps in order to - switch protocol family between `PF_INET' and `PF_INET6'. - - For another example using `IO::Poll' and `Net::LibAsyncNS', see the - examples/nonblocking_libasyncns.pl file in the module distribution. - -`PeerHost' AND `LocalHost' PARSING - To support the `IO::Socket::INET' API, the host and port information may - be passed in a single string rather than as two separate arguments. - - If either `LocalHost' or `PeerHost' (or their `...Addr' synonyms) have - any of the following special forms then special parsing is applied. - - The value of the `...Host' argument will be split to give both the - hostname and port (or service name): - - hostname.example.org:http # Host name - 192.0.2.1:80 # IPv4 address - [2001:db8::1]:80 # IPv6 address - - In each case, the port or service name (e.g. `80') is passed as the - `LocalService' or `PeerService' argument. - - Either of `LocalService' or `PeerService' (or their `...Port' synonyms) - can be either a service name, a decimal number, or a string containing - both a service name and number, in a form such as - - http(80) - - In this case, the name (`http') will be tried first, but if the resolver - does not understand it then the port number (`80') will be used instead. - - If the `...Host' argument is in this special form and the corresponding - `...Service' or `...Port' argument is also defined, the one parsed from - the `...Host' argument will take precedence and the other will be - ignored. - - ( $host, $port ) = IO::Socket::IP->split_addr( $addr ) - Utility method that provides the parsing functionality described above. - Returns a 2-element list, containing either the split hostname and port - description if it could be parsed, or the given address and `undef' if - it was not recognised. - - IO::Socket::IP->split_addr( "hostname:http" ) - # ( "hostname", "http" ) - - IO::Socket::IP->split_addr( "192.0.2.1:80" ) - # ( "192.0.2.1", "80" ) - - IO::Socket::IP->split_addr( "[2001:db8::1]:80" ) - # ( "2001:db8::1", "80" ) - - IO::Socket::IP->split_addr( "something.else" ) - # ( "something.else", undef ) - - $addr = IO::Socket::IP->join_addr( $host, $port ) - Utility method that performs the reverse of `split_addr', returning a - string formed by joining the specified host address and port number. The - host address will be wrapped in `[]' brackets if required (because it is - a raw IPv6 numeric address). - - This can be especially useful when combined with the `sockhost_service' - or `peerhost_service' methods. - - say "Connected to ", IO::Socket::IP->join_addr( $sock->peerhost_service ); - -`IO::Socket::INET' INCOMPATIBILITES - * The behaviour enabled by `MultiHomed' is in fact implemented by - `IO::Socket::IP' as it is required to correctly support searching - for a useable address from the results of the `getaddrinfo(3)' call. - The constructor will ignore the value of this argument, except if it - is defined but false. An exception is thrown in this case, because - that would request it disable the `getaddrinfo(3)' search behaviour - in the first place. - -TODO - * Investigate whether `POSIX::dup2' upsets BSD's `kqueue' watchers, - and if so, consider what possible workarounds might be applied. - -AUTHOR - Paul Evans - diff --git a/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm b/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm index 30e0464..af783f2 100644 --- a/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm +++ b/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm @@ -7,7 +7,7 @@ package IO::Socket::IP; # $VERSION needs to be set before use base 'IO::Socket' # - https://rt.cpan.org/Ticket/Display.html?id=92107 BEGIN { - $VERSION = '0.29'; + $VERSION = '0.31'; } use strict; @@ -611,6 +611,13 @@ sub setup return 0; } + # If connect failed but we have no system error there must be an error + # at the application layer, like a bad certificate with + # IO::Socket::SSL. + # In this case don't continue IP based multi-homing because the problem + # cannot be solved at the IP layer. + return 0 if ! $!; + ${*$self}{io_socket_ip_errors}[0] = $!; next; } @@ -651,7 +658,7 @@ sub connect # (still in progress). This even works on MSWin32. my $addr = ${*$self}{io_socket_ip_infos}[${*$self}{io_socket_ip_idx}]{peeraddr}; - if( $self->connect( $addr ) or $! == EISCONN ) { + if( CORE::connect( $self, $addr ) or $! == EISCONN ) { delete ${*$self}{io_socket_ip_connect_in_progress}; $! = 0; return 1; diff --git a/cpan/IO-Socket-IP/t/15io-socket.t b/cpan/IO-Socket-IP/t/15io-socket.t index 1b0cc4e..8acc9a7 100644 --- a/cpan/IO-Socket-IP/t/15io-socket.t +++ b/cpan/IO-Socket-IP/t/15io-socket.t @@ -17,7 +17,8 @@ use IO::Socket::IP -register; LocalPort => 0, ); - isa_ok( $sock, "IO::Socket::IP", 'IO::Socket->new( Domain => AF_INET )' ); + isa_ok( $sock, "IO::Socket::IP", 'IO::Socket->new( Domain => AF_INET )' ) or + diag( " error was $@" ); $sock = IO::Socket->new( Domain => AF_INET, diff --git a/cpan/Pod-Usage/lib/Pod/Usage.pm b/cpan/Pod-Usage/lib/Pod/Usage.pm index f0dd835..bb8e60f 100644 --- a/cpan/Pod-Usage/lib/Pod/Usage.pm +++ b/cpan/Pod-Usage/lib/Pod/Usage.pm @@ -11,7 +11,7 @@ package Pod::Usage; use strict; use vars qw($VERSION @ISA @EXPORT); -$VERSION = '1.63'; ## Current version of this package +$VERSION = '1.64'; ## Current version of this package require 5.006; ## requires this Perl version or later #use diagnostics; @@ -360,7 +360,7 @@ __END__ =head1 NAME -Pod::Usage, pod2usage() - print a usage message from embedded pod documentation +Pod::Usage - print a usage message from embedded pod documentation =head1 SYNOPSIS @@ -594,13 +594,15 @@ use them by default if you don't expressly tell it to do otherwise. The ability of B to accept a single number or a string makes it convenient to use as an innocent looking error message handling function: + use strict; use Pod::Usage; use Getopt::Long; ## Parse options - GetOptions("help", "man", "flag1") || pod2usage(2); - pod2usage(1) if ($opt_help); - pod2usage(-verbose => 2) if ($opt_man); + my %opt; + GetOptions(\%opt, "help|?", "man", "flag1") || pod2usage(2); + pod2usage(1) if ($opt{help}); + pod2usage(-exitval => 0, -verbose => 2) if ($opt{man}); ## Check for too many filenames pod2usage("$0: Too many files given.\n") if (@ARGV > 1); @@ -609,23 +611,35 @@ Some user's however may feel that the above "economy of expression" is not particularly readable nor consistent and may instead choose to do something more like the following: - use Pod::Usage; - use Getopt::Long; + use strict; + use Pod::Usage qw(pod2usage); + use Getopt::Long qw(GetOptions); ## Parse options - GetOptions("help", "man", "flag1") || pod2usage(-verbose => 0); - pod2usage(-verbose => 1) if ($opt_help); - pod2usage(-verbose => 2) if ($opt_man); + my %opt; + GetOptions(\%opt, "help|?", "man", "flag1") || + pod2usage(-verbose => 0); + + pod2usage(-verbose => 1) if ($opt{help}); + pod2usage(-verbose => 2) if ($opt{man}); ## Check for too many filenames pod2usage(-verbose => 2, -message => "$0: Too many files given.\n") - if (@ARGV > 1); + if (@ARGV > 1); + As with all things in Perl, I, and B adheres to this philosophy. If you are interested in seeing a number of different ways to invoke B (although by no means exhaustive), please refer to L<"EXAMPLES">. +=head2 Scripts + +The Pod::Usage distribution comes with a script pod2usage which offers +a command line interface to the functionality of Pod::Usage. See +L. + + =head1 EXAMPLES Each of the following invocations of C will print just the @@ -709,8 +723,9 @@ provide a means of printing their complete documentation to C uses B in combination with B to do all of these things: - use Getopt::Long; - use Pod::Usage; + use strict; + use Getopt::Long qw(GetOptions); + use Pod::Usage qw(pod2usage); my $man = 0; my $help = 0; @@ -723,6 +738,7 @@ things: ## If no arguments were given, then allow STDIN to be used only ## if it's not connected to a terminal (otherwise print usage) pod2usage("$0: No files given.") if ((@ARGV == 0) && (-t STDIN)); + __END__ =head1 NAME @@ -739,7 +755,7 @@ things: =head1 OPTIONS - =over 8 + =over 4 =item B<-help> diff --git a/cpan/experimental/lib/experimental.pm b/cpan/experimental/lib/experimental.pm index 1c43e10..96f8a41 100644 --- a/cpan/experimental/lib/experimental.pm +++ b/cpan/experimental/lib/experimental.pm @@ -1,7 +1,8 @@ package experimental; -$experimental::VERSION = '0.007'; +$experimental::VERSION = '0.008'; use strict; use warnings; +use version (); use feature (); use Carp qw/croak carp/; @@ -10,12 +11,12 @@ my %warnings = map { $_ => 1 } grep { /^experimental::/ } keys %warnings::Offset my %features = map { $_ => 1 } keys %feature::feature; my %min_version = ( - array_base => 5, - autoderef => 5.014000, - lexical_topic => 5.010000, - regex_sets => 5.018000, - smartmatch => 5.010001, - signatures => 5.019009, # change to 5.20.0 someday? -- rjbs, 2014-02-08 + array_base => version->new('5'), + autoderef => version->new('5.14.0'), + lexical_topic => version->new('5.10.0'), + regex_sets => version->new('5.18.0'), + smartmatch => version->new('5.10.1'), + signatures => version->new('5.20.0'), ); my %additional = ( @@ -38,7 +39,7 @@ sub _enable { croak "Can't enable unknown feature $pragma"; } elsif ($min_version{$pragma} > $]) { - croak "Need perl version $min_version{$pragma} or later for feature $pragma"; + croak "Need perl $min_version{$pragma} or later for feature $pragma"; } } @@ -92,7 +93,7 @@ experimental - Experimental features made easy =head1 VERSION -version 0.007 +version 0.008 =head1 SYNOPSIS @@ -130,7 +131,8 @@ The supported features, documented further below, are: in interpolating strings regex_sets - allow extended bracketed character classes in regexps signatures - allow subroutine signatures (for named arguments) - smartmatch - allow the use of ~~, given, and when + smartmatch - allow the use of ~~ + switch - allow the use of ~~, given, and when =head2 Disclaimer diff --git a/deb.c b/deb.c index 433ae11..d1c3fe9 100644 --- a/deb.c +++ b/deb.c @@ -166,7 +166,6 @@ I32 Perl_debstack(pTHX) { #ifndef SKIP_DEBUGGING - dVAR; if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) return 0; diff --git a/dist/Data-Dumper/t/dumper.t b/dist/Data-Dumper/t/dumper.t index 624e0bb..f452ad2 100644 --- a/dist/Data-Dumper/t/dumper.t +++ b/dist/Data-Dumper/t/dumper.t @@ -1679,7 +1679,6 @@ OLD EOW TEST q(Data::Dumper->new([ \&foo, \\&foo ], [ "*a", "b" ])->Dump), "name of code in *foo"; - local $TODO = "XS code broken"; TEST q(Data::Dumper->new([ \&foo, \\&foo ], [ "*a", "b" ])->Dumpxs), "name of code in *foo xs" if $XS; } diff --git a/dist/ExtUtils-Manifest/lib/ExtUtils/MANIFEST.SKIP b/dist/ExtUtils-Manifest/lib/ExtUtils/MANIFEST.SKIP index bea6874..725f84e 100644 --- a/dist/ExtUtils-Manifest/lib/ExtUtils/MANIFEST.SKIP +++ b/dist/ExtUtils-Manifest/lib/ExtUtils/MANIFEST.SKIP @@ -40,6 +40,7 @@ \.tmp$ \.# \.rej$ +\..*\.sw.?$ # Avoid OS-specific files/dirs # Mac OSX metadata @@ -51,5 +52,8 @@ \bcover_db\b \bcovered\b +# Avoid prove files +\B\.prove$ + # Avoid MYMETA files ^MYMETA\. diff --git a/dist/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm b/dist/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm index 5bcd6d6..165a15c 100644 --- a/dist/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm +++ b/dist/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm @@ -8,24 +8,22 @@ use File::Find; use File::Spec; use Carp; use strict; +use warnings; -use vars qw($VERSION @ISA @EXPORT_OK - $Is_MacOS $Is_VMS $Is_VMS_mode $Is_VMS_lc $Is_VMS_nodot - $Debug $Verbose $Quiet $MANIFEST $DEFAULT_MSKIP); +use Exporter 5.57 'import'; -$VERSION = '1.63'; -@ISA=('Exporter'); -@EXPORT_OK = qw(mkmanifest +our $VERSION = '1.64'; +our @EXPORT_OK = qw(mkmanifest manicheck filecheck fullcheck skipcheck manifind maniread manicopy maniadd maniskip ); -$Is_MacOS = $^O eq 'MacOS'; -$Is_VMS = $^O eq 'VMS'; -$Is_VMS_mode = 0; -$Is_VMS_lc = 0; -$Is_VMS_nodot = 0; # No dots in dir names or double dots in files +our $Is_MacOS = $^O eq 'MacOS'; +our $Is_VMS = $^O eq 'VMS'; +our $Is_VMS_mode = 0; +our $Is_VMS_lc = 0; +our $Is_VMS_nodot = 0; # No dots in dir names or double dots in files if ($Is_VMS) { require VMS::Filespec if $Is_VMS; @@ -53,13 +51,13 @@ if ($Is_VMS) { $Is_VMS_nodot = 0 if ($vms_efs); } -$Debug = $ENV{PERL_MM_MANIFEST_DEBUG} || 0; -$Verbose = defined $ENV{PERL_MM_MANIFEST_VERBOSE} ? +our $Debug = $ENV{PERL_MM_MANIFEST_DEBUG} || 0; +our $Verbose = defined $ENV{PERL_MM_MANIFEST_VERBOSE} ? $ENV{PERL_MM_MANIFEST_VERBOSE} : 1; -$Quiet = 0; -$MANIFEST = 'MANIFEST'; +our $Quiet = 0; +our $MANIFEST = 'MANIFEST'; -$DEFAULT_MSKIP = File::Spec->catfile( dirname(__FILE__), "$MANIFEST.SKIP" ); +our $DEFAULT_MSKIP = File::Spec->catfile( dirname(__FILE__), "$MANIFEST.SKIP" ); =head1 NAME diff --git a/dist/Filter-Simple/lib/Filter/Simple.pm b/dist/Filter-Simple/lib/Filter/Simple.pm index 4b15e55..8212919 100644 --- a/dist/Filter-Simple/lib/Filter/Simple.pm +++ b/dist/Filter-Simple/lib/Filter/Simple.pm @@ -4,7 +4,7 @@ use Text::Balanced ':ALL'; use vars qw{ $VERSION @EXPORT }; -$VERSION = '0.91'; +$VERSION = '0.92'; use Filter::Util::Call; use Carp; @@ -119,8 +119,8 @@ sub gen_std_filter_for { } if ($type =~ /^code/) { my $count = 0; - local $placeholder = qr/\Q$;\E(\C{4})\Q$;\E/; - my $extractor = qr/\Q$;\E(\C{4})\Q$;\E/; + local $placeholder = qr/\Q$;\E(.{4})\Q$;\E/s; + my $extractor = qr/\Q$;\E(.{4})\Q$;\E/s; $_ = join "", map { ref $_ ? $;.pack('N',$count++).$; : $_ } @components; diff --git a/dist/IO/IO.pm b/dist/IO/IO.pm index 28f9ce5..36c028a 100644 --- a/dist/IO/IO.pm +++ b/dist/IO/IO.pm @@ -7,7 +7,7 @@ use Carp; use strict; use warnings; -our $VERSION = "1.32"; +our $VERSION = "1.33"; XSLoader::load 'IO', $VERSION; sub import { diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs index 4dc9149..5e30795 100644 --- a/dist/IO/IO.xs +++ b/dist/IO/IO.xs @@ -191,7 +191,7 @@ static OP * io_ck_lineseq(pTHX_ OP *o) { OP *kid = cBINOPo->op_first; - for (; kid; kid = kid->op_sibling) + for (; kid; kid = OP_SIBLING(kid)) if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) kid->op_ppaddr = io_pp_nextstate; return o; diff --git a/dist/IO/t/io_taint.t b/dist/IO/t/io_taint.t index 5740353..7c3ffe6 100644 --- a/dist/IO/t/io_taint.t +++ b/dist/IO/t/io_taint.t @@ -33,7 +33,7 @@ chop(my $unsafe = <$x>); eval { kill 0 * $unsafe }; SKIP: { skip($^O) if $^O eq 'MSWin32' or $^O eq 'NetWare'; - like($@, '^Insecure'); + like($@, qr/^Insecure/); } $x->close; @@ -44,7 +44,7 @@ $x->untaint; ok(!$?); # Calling the method worked chop($unsafe = <$x>); eval { kill 0 * $unsafe }; -unlike($@,'^Insecure'); +unlike($@,qr/^Insecure/); $x->close; TODO: { diff --git a/dist/Math-BigInt/lib/Math/BigFloat.pm b/dist/Math-BigInt/lib/Math/BigFloat.pm index 8614bba..e022949 100644 --- a/dist/Math-BigInt/lib/Math/BigFloat.pm +++ b/dist/Math-BigInt/lib/Math/BigFloat.pm @@ -12,7 +12,7 @@ package Math::BigFloat; # _a : accuracy # _p : precision -$VERSION = '1.9994'; +$VERSION = '1.9996'; require 5.006002; require Exporter; diff --git a/dist/Math-BigInt/lib/Math/BigInt.pm b/dist/Math-BigInt/lib/Math/BigInt.pm index 7dd3d41..69fd320 100644 --- a/dist/Math-BigInt/lib/Math/BigInt.pm +++ b/dist/Math-BigInt/lib/Math/BigInt.pm @@ -18,7 +18,7 @@ package Math::BigInt; my $class = "Math::BigInt"; use 5.006002; -$VERSION = '1.9995'; +$VERSION = '1.9996'; @ISA = qw(Exporter); @EXPORT_OK = qw(objectify bgcd blcm); @@ -2675,28 +2675,22 @@ sub objectify { for my $i (1 .. $count) { my $ref = ref $a[$i]; - # If it is an object of the right class, all is fine. - - if ($ref eq $a[0]) { - next; - } - - # Don't do anything with undefs. + # Perl scalars are fed to the appropriate constructor. - unless (defined($a[$i])) { + unless ($ref) { + $a[$i] = $a[0] -> new($a[$i]); next; } - # Perl scalars are fed to the appropriate constructor. + # If it is an object of the right class, all is fine. - unless ($ref) { - $a[$i] = $a[0] -> new($a[$i]); + if ($ref -> isa($a[0])) { next; } # Upgrading is OK, so skip further tests if the argument is upgraded. - if (defined $up && $ref eq $up) { + if (defined $up && $ref -> isa($up)) { next; } diff --git a/dist/Math-BigInt/lib/Math/BigInt/Calc.pm b/dist/Math-BigInt/lib/Math/BigInt/Calc.pm index 97815f7..588e2ac 100644 --- a/dist/Math-BigInt/lib/Math/BigInt/Calc.pm +++ b/dist/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.9994'; +our $VERSION = '1.9996'; # Package to store unsigned big integers in decimal and do math with them diff --git a/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm b/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm index 544455f..1a83f09 100644 --- a/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm +++ b/dist/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.9994'; +$VERSION = '1.9996'; package Math::BigInt; diff --git a/dist/Module-CoreList/Changes b/dist/Module-CoreList/Changes index ba5b4a2..fcd153e 100644 --- a/dist/Module-CoreList/Changes +++ b/dist/Module-CoreList/Changes @@ -1,3 +1,6 @@ +5.021002 + - Prepared for v5.21.2 + 5.021001_01 - Prepared for v5.21.1 diff --git a/dist/Module-CoreList/lib/Module/CoreList.pm b/dist/Module-CoreList/lib/Module/CoreList.pm index aa93f5b..7ed0ea2 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.021001_01'; +$VERSION = '5.021002'; my $dumpinc = 0; sub import { @@ -250,7 +250,8 @@ sub changes_between { 5.019011 => '2014-04-20', 5.020000 => '2014-05-27', 5.021000 => '2014-05-27', - 5.021001 => '????-??-??', + 5.021001 => '2014-06-20', + 5.021002 => '2014-07-20', ); for my $version ( sort { $a <=> $b } keys %released ) { @@ -10040,6 +10041,47 @@ for my $version ( sort { $a <=> $b } keys %released ) { removed => { } }, + 5.021002 => { + delta_from => 5.021001, + changed => { + 'B' => '1.50', + 'Config' => '5.021002', + 'Cwd' => '3.49', + 'Devel::Peek' => '1.18', + 'ExtUtils::Manifest' => '1.64', + 'File::Copy' => '2.30', + 'File::Spec' => '3.49', + 'File::Spec::Cygwin' => '3.49', + 'File::Spec::Epoc' => '3.49', + 'File::Spec::Functions' => '3.49', + 'File::Spec::Mac' => '3.49', + 'File::Spec::OS2' => '3.49', + 'File::Spec::Unix' => '3.49', + 'File::Spec::VMS' => '3.49', + 'File::Spec::Win32' => '3.49', + 'Filter::Simple' => '0.92', + 'Hash::Util' => '0.18', + 'IO' => '1.33', + 'IO::Socket::IP' => '0.31', + 'IPC::Open3' => '1.17', + 'Math::BigFloat' => '1.9996', + 'Math::BigInt' => '1.9996', + 'Math::BigInt::Calc' => '1.9996', + 'Math::BigInt::CalcEmu' => '1.9996', + 'Module::CoreList' => '5.021002', + 'Module::CoreList::TieHashDelta'=> '5.021002', + 'Module::CoreList::Utils'=> '5.021002', + 'POSIX' => '1.41', + 'Pod::Usage' => '1.64', + 'XS::APItest' => '0.62', + 'arybase' => '0.08', + 'experimental' => '0.008', + 'threads' => '1.95', + 'warnings' => '1.26', + }, + removed => { + } + }, ); sub is_core @@ -10455,6 +10497,13 @@ for my $version (sort { $a <=> $b } keys %delta) { removed => { } }, + 5.021002 => { + delta_from => 5.021001, + changed => { + }, + removed => { + } + }, ); for my $version (sort { $a <=> $b } keys %deprecated) { diff --git a/dist/Module-CoreList/lib/Module/CoreList.pod b/dist/Module-CoreList/lib/Module/CoreList.pod index cc6ad1a..be37e4d 100644 --- a/dist/Module-CoreList/lib/Module/CoreList.pod +++ b/dist/Module-CoreList/lib/Module/CoreList.pod @@ -230,7 +230,7 @@ Module::CoreList currently covers the 5.000, 5.001, 5.002, 5.003_07, 5.15.9, 5.16.0, 5.16.1, 5.16.2, 5.16.3, 5.17.0, 5.17.1, 5.17.2, 5.17.3, 5.17.4, 5.17.5, 5.17.6, 5.17.7, 5.17.8, 5.17.9, 5.17.10, 5.17.11, 5.18.0, 5.19.0, 5.19.1, 5.19.2, 5.19.3, 5.19.4, 5.19.5, 5.19.6, 5.19.7, 5.19.8, -5.19.9, 5.19.10, 5.19.11, 5.20.0, 5.21.0 and 5.21.1 releases of perl. +5.19.9, 5.19.10, 5.19.11, 5.20.0, 5.21.0, 5.21.1 and 5.21.2 releases of perl. =head1 HISTORY diff --git a/dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm b/dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm index fd24ef1..a9fd403 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.021001_01'; +$VERSION = '5.021002'; sub TIEHASH { my ($class, $changed, $removed, $parent) = @_; @@ -32,12 +32,14 @@ sub FETCH { sub EXISTS { my ($self, $key) = @_; + restart: if (exists $self->{changed}{$key}) { return 1; } elsif (exists $self->{removed}{$key}) { return ''; } elsif (defined $self->{parent}) { - return exists $self->{parent}{$key}; + $self = tied %{$self->{parent}}; #avoid extreme magic/tie recursion + goto restart; } return ''; } diff --git a/dist/Module-CoreList/lib/Module/CoreList/Utils.pm b/dist/Module-CoreList/lib/Module/CoreList/Utils.pm index b3ac48d..218c37a 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.021001_01'; +$VERSION = '5.021002'; sub utilities { my $perl = shift; @@ -936,6 +936,13 @@ my %delta = ( 's2p' => 1, } }, + 5.021002 => { + delta_from => 5.021001, + changed => { + }, + removed => { + } + }, ); for my $version (sort { $a <=> $b } keys %delta) { diff --git a/dist/PathTools/Cwd.pm b/dist/PathTools/Cwd.pm index 01393f3..461e94d 100644 --- a/dist/PathTools/Cwd.pm +++ b/dist/PathTools/Cwd.pm @@ -171,7 +171,7 @@ use strict; use Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); -$VERSION = '3.48'; +$VERSION = '3.49'; my $xs_version = $VERSION; $VERSION =~ tr/_//; @@ -242,8 +242,10 @@ sub _vms_efs { # If loading the XS stuff doesn't work, we can fall back to pure perl -unless (defined &getcwd) { - eval { +if(! defined &getcwd && defined &DynaLoader::boot_DynaLoader) { + eval {#eval is questionable since we are handling potential errors like + #"Cwd object version 3.48 does not match bootstrap parameter 3.49 + #at lib/DynaLoader.pm line 216." by having this eval if ( $] >= 5.006 ) { require XSLoader; XSLoader::load( __PACKAGE__, $xs_version); diff --git a/dist/PathTools/lib/File/Spec.pm b/dist/PathTools/lib/File/Spec.pm index bf0a327..e5cb815 100644 --- a/dist/PathTools/lib/File/Spec.pm +++ b/dist/PathTools/lib/File/Spec.pm @@ -3,7 +3,7 @@ package File::Spec; use strict; use vars qw(@ISA $VERSION); -$VERSION = '3.48'; +$VERSION = '3.49'; $VERSION =~ tr/_//; my %module = (MacOS => 'Mac', diff --git a/dist/PathTools/lib/File/Spec/Cygwin.pm b/dist/PathTools/lib/File/Spec/Cygwin.pm index a791a2a..ef3b0a2 100644 --- a/dist/PathTools/lib/File/Spec/Cygwin.pm +++ b/dist/PathTools/lib/File/Spec/Cygwin.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.48'; +$VERSION = '3.49'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); diff --git a/dist/PathTools/lib/File/Spec/Epoc.pm b/dist/PathTools/lib/File/Spec/Epoc.pm index a7859c5..4dbc13d 100644 --- a/dist/PathTools/lib/File/Spec/Epoc.pm +++ b/dist/PathTools/lib/File/Spec/Epoc.pm @@ -3,7 +3,7 @@ package File::Spec::Epoc; use strict; use vars qw($VERSION @ISA); -$VERSION = '3.48'; +$VERSION = '3.49'; $VERSION =~ tr/_//; require File::Spec::Unix; diff --git a/dist/PathTools/lib/File/Spec/Functions.pm b/dist/PathTools/lib/File/Spec/Functions.pm index 0170843..1bbfaae 100644 --- a/dist/PathTools/lib/File/Spec/Functions.pm +++ b/dist/PathTools/lib/File/Spec/Functions.pm @@ -5,7 +5,7 @@ use strict; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); -$VERSION = '3.48'; +$VERSION = '3.49'; $VERSION =~ tr/_//; require Exporter; diff --git a/dist/PathTools/lib/File/Spec/Mac.pm b/dist/PathTools/lib/File/Spec/Mac.pm index a8dc2df..42a5d4a 100644 --- a/dist/PathTools/lib/File/Spec/Mac.pm +++ b/dist/PathTools/lib/File/Spec/Mac.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.48'; +$VERSION = '3.49'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); diff --git a/dist/PathTools/lib/File/Spec/OS2.pm b/dist/PathTools/lib/File/Spec/OS2.pm index df458c9..9202c3c 100644 --- a/dist/PathTools/lib/File/Spec/OS2.pm +++ b/dist/PathTools/lib/File/Spec/OS2.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.48'; +$VERSION = '3.49'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); diff --git a/dist/PathTools/lib/File/Spec/Unix.pm b/dist/PathTools/lib/File/Spec/Unix.pm index e4eddbb..3a3537c 100644 --- a/dist/PathTools/lib/File/Spec/Unix.pm +++ b/dist/PathTools/lib/File/Spec/Unix.pm @@ -3,12 +3,15 @@ package File::Spec::Unix; use strict; use vars qw($VERSION); -$VERSION = '3.48'; +$VERSION = '3.49'; my $xs_version = $VERSION; $VERSION =~ tr/_//; -unless (defined &canonpath) { - eval { +#dont try to load XSLoader and DynaLoader only to ultimately fail on miniperl +if(!defined &canonpath && defined &DynaLoader::boot_DynaLoader) { + eval {#eval is questionable since we are handling potential errors like + #"Cwd object version 3.48 does not match bootstrap parameter 3.49 + #at lib/DynaLoader.pm line 216." by having this eval if ( $] >= 5.006 ) { require XSLoader; XSLoader::load("Cwd", $xs_version); diff --git a/dist/PathTools/lib/File/Spec/VMS.pm b/dist/PathTools/lib/File/Spec/VMS.pm index b045e27..82801f4 100644 --- a/dist/PathTools/lib/File/Spec/VMS.pm +++ b/dist/PathTools/lib/File/Spec/VMS.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.48'; +$VERSION = '3.49'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); diff --git a/dist/PathTools/lib/File/Spec/Win32.pm b/dist/PathTools/lib/File/Spec/Win32.pm index 352ec99..7195a31 100644 --- a/dist/PathTools/lib/File/Spec/Win32.pm +++ b/dist/PathTools/lib/File/Spec/Win32.pm @@ -5,7 +5,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.48'; +$VERSION = '3.49'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); diff --git a/dist/Storable/ChangeLog b/dist/Storable/ChangeLog index b4d2c40..4df921e 100644 --- a/dist/Storable/ChangeLog +++ b/dist/Storable/ChangeLog @@ -1,5 +1,11 @@ - [perl #121928] Fix memory leak for dclone inside freeze hook - (Alex Solovey) +Wed Jul 2 16:25:25 IST 2014 Abhijit Menon-Sen + Version 2.51 + + * [perl #121928] Fix memory leak for dclone inside freeze hook + (Alex Solovey) + * Do not call DESTROY for empty objects + (Vladimir Timofeev) + * Other bugfixes Sat Jul 13 18:34:27 IST 2013 Abhijit Menon-Sen Version 2.45 diff --git a/dist/lib/t/01lib.t b/dist/lib/t/01lib.t index f58fce5..2a103d4 100644 --- a/dist/lib/t/01lib.t +++ b/dist/lib/t/01lib.t @@ -62,7 +62,7 @@ BEGIN { is( eval { do 'Yup.pm' }, 42, 'do() works' ); ok( eval { require Yup; }, ' require()' ); ok( eval "use Yup; 1;", ' use()' ); - is( $@, '' ); + is( $@, '', 'last "eval()" parsed and executed correctly' ); is_deeply(\@OrigINC, \@lib::ORIG_INC, '@lib::ORIG_INC' ); } diff --git a/dist/threads/lib/threads.pm b/dist/threads/lib/threads.pm index c395d7b..ff41a20 100644 --- a/dist/threads/lib/threads.pm +++ b/dist/threads/lib/threads.pm @@ -5,7 +5,7 @@ use 5.008; use strict; use warnings; -our $VERSION = '1.94'; +our $VERSION = '1.95'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/dist/threads/t/err.t b/dist/threads/t/err.t index f5e0a19..b708823 100644 --- a/dist/threads/t/err.t +++ b/dist/threads/t/err.t @@ -28,7 +28,7 @@ my $result = $thr->join(); ok(! defined($result), 'thread died'); # Check error -like($thr->error(), q/Can't locate object method/, 'thread error'); +like($thr->error(), qr/^Can't locate object method/s, 'thread error'); # Create a thread that 'die's with an object diff --git a/dist/threads/t/exit.t b/dist/threads/t/exit.t index 6acad2f..2879e2b 100644 --- a/dist/threads/t/exit.t +++ b/dist/threads/t/exit.t @@ -121,7 +121,7 @@ my $out = run_perl(prog => 'use threads 1.92;' . local $TODO = 'VMS exit semantics not like POSIX exit semantics' if $^O eq 'VMS'; is($?>>8, 99, "exit(status) in thread"); } -like($out, '1 finished and unjoined', "exit(status) in thread"); +like($out, qr/1 finished and unjoined/, "exit(status) in thread"); $out = run_perl(prog => 'use threads 1.92 qw(exit thread_only);' . @@ -138,7 +138,7 @@ $out = run_perl(prog => 'use threads 1.92 qw(exit thread_only);' . local $TODO = 'VMS exit semantics not like POSIX exit semantics' if $^O eq 'VMS'; is($?>>8, 99, "set_thread_exit_only(0)"); } -like($out, '1 finished and unjoined', "set_thread_exit_only(0)"); +like($out, qr/1 finished and unjoined/, "set_thread_exit_only(0)"); run_perl(prog => 'use threads 1.92;' . diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs index 6175ba7..5b44a38 100644 --- a/dist/threads/threads.xs +++ b/dist/threads/threads.xs @@ -346,7 +346,7 @@ S_exit_warning(pTHX) /* Called from perl_destruct() in each thread. If it's the main thread, * stop it from freeing everything if there are other threads still running. */ -int +STATIC int Perl_ithread_hook(pTHX) { dMY_POOL; @@ -356,7 +356,7 @@ Perl_ithread_hook(pTHX) /* MAGIC (in mg.h sense) hooks */ -int +STATIC int ithread_mg_get(pTHX_ SV *sv, MAGIC *mg) { ithread *thread = (ithread *)mg->mg_ptr; @@ -365,7 +365,7 @@ ithread_mg_get(pTHX_ SV *sv, MAGIC *mg) return (0); } -int +STATIC int ithread_mg_free(pTHX_ SV *sv, MAGIC *mg) { ithread *thread = (ithread *)mg->mg_ptr; @@ -375,7 +375,7 @@ ithread_mg_free(pTHX_ SV *sv, MAGIC *mg) return (0); } -int +STATIC int ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) { PERL_UNUSED_ARG(param); @@ -383,7 +383,7 @@ ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) return (0); } -MGVTBL ithread_vtbl = { +STATIC const MGVTBL ithread_vtbl = { ithread_mg_get, /* get */ 0, /* set */ 0, /* len */ diff --git a/doio.c b/doio.c index feb52df..46d0796 100644 --- a/doio.c +++ b/doio.c @@ -64,7 +64,6 @@ static IO * S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp, int *savefd, char *savetype) { - dVAR; IO * const io = GvIOn(gv); PERL_ARGS_ASSERT_OPENN_SETUP; @@ -145,7 +144,6 @@ bool Perl_do_open_raw(pTHX_ GV *gv, const char *oname, STRLEN len, int rawmode, int rawperm) { - dVAR; PerlIO *saveifp; PerlIO *saveofp; int savefd; @@ -215,7 +213,6 @@ bool Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len, PerlIO *supplied_fp, SV **svp, U32 num_svs) { - dVAR; PerlIO *saveifp; PerlIO *saveofp; int savefd; @@ -804,7 +801,6 @@ say_false: PerlIO * Perl_nextargv(pTHX_ GV *gv) { - dVAR; IO * const io = GvIOp(gv); PERL_ARGS_ASSERT_NEXTARGV; @@ -1027,7 +1023,6 @@ Perl_nextargv(pTHX_ GV *gv) bool Perl_do_close(pTHX_ GV *gv, bool not_implicit) { - dVAR; bool retval; IO *io; @@ -1059,7 +1054,6 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) bool Perl_io_close(pTHX_ IO *io, bool not_implicit) { - dVAR; bool retval = FALSE; PERL_ARGS_ASSERT_IO_CLOSE; @@ -1100,7 +1094,6 @@ Perl_io_close(pTHX_ IO *io, bool not_implicit) bool Perl_do_eof(pTHX_ GV *gv) { - dVAR; IO * const io = GvIO(gv); PERL_ARGS_ASSERT_DO_EOF; @@ -1145,7 +1138,6 @@ Perl_do_eof(pTHX_ GV *gv) Off_t Perl_do_tell(pTHX_ GV *gv) { - dVAR; IO *const io = GvIO(gv); PerlIO *fp; @@ -1162,7 +1154,6 @@ Perl_do_tell(pTHX_ GV *gv) bool Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) { - dVAR; IO *const io = GvIO(gv); PerlIO *fp; @@ -1177,7 +1168,6 @@ Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) Off_t Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence) { - dVAR; IO *const io = GvIO(gv); PerlIO *fp; @@ -1305,8 +1295,6 @@ my_chsize(int fd, Off_t length) bool Perl_do_print(pTHX_ SV *sv, PerlIO *fp) { - dVAR; - PERL_ARGS_ASSERT_DO_PRINT; /* assuming fp is checked earlier */ @@ -1378,7 +1366,6 @@ Perl_do_print(pTHX_ SV *sv, PerlIO *fp) I32 Perl_my_stat_flags(pTHX_ const U32 flags) { - dVAR; dSP; IO *io; GV* gv; @@ -1445,7 +1432,6 @@ Perl_my_stat_flags(pTHX_ const U32 flags) I32 Perl_my_lstat_flags(pTHX_ const U32 flags) { - dVAR; static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat"; dSP; const char *file; @@ -1561,7 +1547,6 @@ Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp, void Perl_do_execfree(pTHX) { - dVAR; Safefree(PL_Argv); PL_Argv = NULL; Safefree(PL_Cmd); @@ -1710,7 +1695,6 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) I32 Perl_apply(pTHX_ I32 type, SV **mark, SV **sp) { - dVAR; I32 val; I32 tot = 0; const char *const what = PL_op_name[type]; @@ -2047,8 +2031,6 @@ Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp) * is in the list of groups returned from getgroups(). */ { - dVAR; - PERL_ARGS_ASSERT_CANDO; PERL_UNUSED_CONTEXT; @@ -2108,7 +2090,6 @@ Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp) static bool S_ingroup(pTHX_ Gid_t testgid, bool effective) { - dVAR; #ifndef PERL_IMPLICIT_SYS /* PERL_IMPLICIT_SYS like Win32: getegid() etc. require the context. */ PERL_UNUSED_CONTEXT; @@ -2145,7 +2126,6 @@ S_ingroup(pTHX_ Gid_t testgid, bool effective) I32 Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) { - dVAR; const key_t key = (key_t)SvNVx(*++mark); SV *nsv = optype == OP_MSGGET ? NULL : *++mark; const I32 flags = SvIVx(*++mark); @@ -2180,7 +2160,6 @@ Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) I32 Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) { - dVAR; char *a; I32 ret = -1; const I32 id = SvIVx(*++mark); @@ -2314,7 +2293,6 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) I32 Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) { - dVAR; #ifdef HAS_MSG STRLEN len; const I32 id = SvIVx(*++mark); @@ -2343,7 +2321,6 @@ I32 Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) { #ifdef HAS_MSG - dVAR; char *mbuf; long mtype; I32 msize, flags, ret; @@ -2384,7 +2361,6 @@ I32 Perl_do_semop(pTHX_ SV **mark, SV **sp) { #ifdef HAS_SEM - dVAR; STRLEN opsize; const I32 id = SvIVx(*++mark); SV * const opstr = *++mark; @@ -2430,7 +2406,6 @@ I32 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) { #ifdef HAS_SHM - dVAR; char *shm; struct shmid_ds shmds; const I32 id = SvIVx(*++mark); @@ -2504,7 +2479,6 @@ Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up. PerlIO * Perl_start_glob (pTHX_ SV *tmpglob, IO *io) { - dVAR; SV * const tmpcmd = newSV(0); PerlIO *fp; STRLEN len; diff --git a/doop.c b/doop.c index 0ba4bb8..6a136d9 100644 --- a/doop.c +++ b/doop.c @@ -30,7 +30,6 @@ STATIC I32 S_do_trans_simple(pTHX_ SV * const sv) { - dVAR; I32 matches = 0; STRLEN len; U8 *s = (U8*)SvPV_nomg(sv,len); @@ -99,7 +98,6 @@ S_do_trans_simple(pTHX_ SV * const sv) STATIC I32 S_do_trans_count(pTHX_ SV * const sv) { - dVAR; STRLEN len; const U8 *s = (const U8*)SvPV_nomg_const(sv, len); const U8 * const send = s + len; @@ -137,7 +135,6 @@ S_do_trans_count(pTHX_ SV * const sv) STATIC I32 S_do_trans_complex(pTHX_ SV * const sv) { - dVAR; STRLEN len; U8 *s = (U8*)SvPV_nomg(sv, len); U8 * const send = s+len; @@ -301,7 +298,6 @@ S_do_trans_complex(pTHX_ SV * const sv) STATIC I32 S_do_trans_simple_utf8(pTHX_ SV * const sv) { - dVAR; U8 *s; U8 *send; U8 *d; @@ -406,7 +402,6 @@ S_do_trans_simple_utf8(pTHX_ SV * const sv) STATIC I32 S_do_trans_count_utf8(pTHX_ SV * const sv) { - dVAR; const U8 *s; const U8 *start = NULL; const U8 *send; @@ -456,7 +451,6 @@ S_do_trans_count_utf8(pTHX_ SV * const sv) STATIC I32 S_do_trans_complex_utf8(pTHX_ SV * const sv) { - dVAR; U8 *start, *send; U8 *d; I32 matches = 0; @@ -624,7 +618,6 @@ S_do_trans_complex_utf8(pTHX_ SV * const sv) I32 Perl_do_trans(pTHX_ SV *sv) { - dVAR; STRLEN len; const I32 hasutf = (PL_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)); @@ -672,7 +665,6 @@ Perl_do_trans(pTHX_ SV *sv) void Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp) { - dVAR; SV ** const oldmark = mark; I32 items = sp - mark; STRLEN len; @@ -731,7 +723,6 @@ Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp) void Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg) { - dVAR; STRLEN patlen; const char * const pat = SvPV_const(*sarg, patlen); bool do_taint = FALSE; @@ -759,7 +750,6 @@ Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg) UV Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size) { - dVAR; STRLEN srclen, len, uoffset, bitoffs = 0; const I32 svpv_flags = ((PL_op->op_flags & OPf_MOD || LVRET) ? SV_UNDEF_RETURNS_NULL : 0); @@ -914,7 +904,6 @@ Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size) void Perl_do_vecset(pTHX_ SV *sv) { - dVAR; SSize_t offset, bitoffs = 0; int size; unsigned char *s; @@ -1001,7 +990,6 @@ Perl_do_vecset(pTHX_ SV *sv) void Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) { - dVAR; #ifdef LIBERAL long *dl; long *ll; @@ -1230,7 +1218,6 @@ finish: OP * Perl_do_kv(pTHX) { - dVAR; dSP; HV * const keys = MUTABLE_HV(POPs); HE *entry; diff --git a/dquote_static.c b/dquote_static.c index 2fcb0fa..802d83b 100644 --- a/dquote_static.c +++ b/dquote_static.c @@ -15,9 +15,8 @@ Pulled from regcomp.c. */ PERL_STATIC_INLINE I32 -S_regcurly(pTHX_ const char *s) +S_regcurly(const char *s) { - PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_REGCURLY; if (*s++ != '{') diff --git a/dump.c b/dump.c index 888866c..d15aee6 100644 --- a/dump.c +++ b/dump.c @@ -495,7 +495,6 @@ Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) void Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) { - dVAR; PERL_ARGS_ASSERT_DUMP_VINDENT; PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); PerlIO_vprintf(file, pat, *args); @@ -520,8 +519,6 @@ Perl_dump_all(pTHX) void Perl_dump_all_perl(pTHX_ bool justperl) { - - dVAR; PerlIO_setlinebuf(Perl_debug_log); if (PL_main_root) op_dump(PL_main_root); @@ -546,7 +543,6 @@ Perl_dump_packsubs(pTHX_ const HV *stash) void Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl) { - dVAR; I32 i; PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL; @@ -625,7 +621,6 @@ Perl_dump_form(pTHX_ const GV *gv) void Perl_dump_eval(pTHX) { - dVAR; op_dump(PL_eval_root); } @@ -906,6 +901,7 @@ S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) { if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \ if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \ if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); \ + if (o->op_lastsib) sv_catpvs(tmpsv, ",LASTSIB"); \ Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \ SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); \ } @@ -1002,7 +998,6 @@ S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) { void Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) { - dVAR; UV seq; const OPCODE optype = o->op_type; @@ -1169,7 +1164,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) } if (o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) do_op_dump(level, file, kid); } Perl_dump_indent(aTHX_ level-1, file, "}\n"); @@ -1534,7 +1529,6 @@ const struct flag_to_name regexp_core_intflags_names[] = { void Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) { - dVAR; SV *d; const char *s; U32 flags; @@ -2322,8 +2316,6 @@ For an example of its output, see L. void Perl_sv_dump(pTHX_ SV *sv) { - dVAR; - PERL_ARGS_ASSERT_SV_DUMP; if (SvROK(sv)) @@ -2335,7 +2327,6 @@ Perl_sv_dump(pTHX_ SV *sv) int Perl_runops_debug(pTHX) { - dVAR; if (!PL_op) { Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); return 0; @@ -2378,7 +2369,6 @@ Perl_runops_debug(pTHX) I32 Perl_debop(pTHX_ const OP *o) { - dVAR; int count; PERL_ARGS_ASSERT_DEBOP; @@ -2455,7 +2445,6 @@ Perl_debop(pTHX_ const OP *o) STATIC CV* S_deb_curcv(pTHX_ const I32 ix) { - dVAR; const PERL_CONTEXT * const cx = &cxstack[ix]; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) return cx->blk_sub.cv; @@ -2472,8 +2461,6 @@ S_deb_curcv(pTHX_ const I32 ix) void Perl_watch(pTHX_ char **addr) { - dVAR; - PERL_ARGS_ASSERT_WATCH; PL_watchaddr = addr; @@ -2485,8 +2472,6 @@ Perl_watch(pTHX_ char **addr) STATIC void S_debprof(pTHX_ const OP *o) { - dVAR; - PERL_ARGS_ASSERT_DEBPROF; if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash)) @@ -2499,7 +2484,6 @@ S_debprof(pTHX_ const OP *o) void Perl_debprofdump(pTHX) { - dVAR; unsigned i; if (!PL_profiledata) return; diff --git a/embed.fnc b/embed.fnc index 45b4838..241a769 100644 --- a/embed.fnc +++ b/embed.fnc @@ -253,10 +253,10 @@ Apd |const PERL_CONTEXT * |caller_cx|I32 level \ |NULLOK const PERL_CONTEXT **dbcxp : Used in several source files pR |bool |cando |Mode_t mode|bool effective|NN const Stat_t* statbufp -ApR |U32 |cast_ulong |NV f -ApR |I32 |cast_i32 |NV f -ApR |IV |cast_iv |NV f -ApR |UV |cast_uv |NV f +ApRn |U32 |cast_ulong |NV f +ApRn |I32 |cast_i32 |NV f +ApRn |IV |cast_iv |NV f +ApRn |UV |cast_uv |NV f #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) ApR |I32 |my_chsize |int fd|Off_t length #endif @@ -312,8 +312,8 @@ EMXp |void |cv_ckproto_len_flags |NN const CV* cv|NULLOK const GV* gv\ |const U32 flags : Used in pp.c and pp_sys.c ApdR |SV* |gv_const_sv |NN GV* gv -ApdR |SV* |cv_const_sv |NULLOK const CV *const cv -pR |SV* |cv_const_sv_or_av|NULLOK const CV *const cv +ApdRn |SV* |cv_const_sv |NULLOK const CV *const cv +pRn |SV* |cv_const_sv_or_av|NULLOK const CV *const cv : Used in pad.c pR |SV* |op_const_sv |NULLOK const OP* o|NULLOK CV* cv Apd |void |cv_undef |NN CV* cv @@ -466,7 +466,7 @@ pR |OP * |parse_subsignature p |char* |find_script |NN const char *scriptname|bool dosearch \ |NULLOK const char *const *const search_ext|I32 flags #if defined(PERL_IN_OP_C) -s |OP* |force_list |NULLOK OP* arg +s |OP* |force_list |NULLOK OP* arg|bool nullit i |OP* |op_integerize |NN OP *o i |OP* |op_std_init |NN OP *o : FIXME @@ -771,6 +771,9 @@ Apd |void |op_null |NN OP* o EXp |void |op_clear |NN OP* o Ap |void |op_refcnt_lock Ap |void |op_refcnt_unlock +Apdn |OP* |op_sibling_splice|NN OP *parent|NULLOK OP *start \ + |int del_count|NULLOK OP* insert +Apdn |OP* |op_parent|NN OP *o #if defined(PERL_IN_OP_C) s |OP* |listkids |NULLOK OP* o #endif @@ -801,6 +804,7 @@ EMsPR |char*|form_short_octal_warning|NN const char * const s \ #endif Apd |UV |grok_hex |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result Apd |int |grok_number |NN const char *pv|STRLEN len|NULLOK UV *valuep +Apd |int |grok_number_flags|NN const char *pv|STRLEN len|NULLOK UV *valuep|U32 flags ApdR |bool |grok_numeric_radix|NN const char **sp|NN const char *send Apd |UV |grok_oct |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result : These are all indirectly referenced by globals.c. This is somewhat annoying. @@ -881,18 +885,18 @@ Apd |int |mg_copy |NN SV *sv|NN SV *nsv|NULLOK const char *key \ |I32 klen : Defined in mg.c, used only in scope.c pd |void |mg_localize |NN SV* sv|NN SV* nsv|bool setmagic -ApdR |MAGIC* |mg_find |NULLOK const SV* sv|int type -ApdR |MAGIC* |mg_findext |NULLOK const SV* sv|int type|NULLOK const MGVTBL *vtbl +ApdRn |MAGIC* |mg_find |NULLOK const SV* sv|int type +ApdRn |MAGIC* |mg_findext |NULLOK const SV* sv|int type|NULLOK const MGVTBL *vtbl : exported for re.pm EXpR |MAGIC* |mg_find_mglob |NN SV* sv Apd |int |mg_free |NN SV* sv Apd |void |mg_free_type |NN SV* sv|int how Apd |int |mg_get |NN SV* sv ApdD |U32 |mg_length |NN SV* sv -Apd |void |mg_magical |NN SV* sv +Apdn |void |mg_magical |NN SV* sv Apd |int |mg_set |NN SV* sv Ap |I32 |mg_size |NN SV* sv -Ap |void |mini_mktime |NN struct tm *ptm +Apn |void |mini_mktime |NN struct tm *ptm AMmd |OP* |op_lvalue |NULLOK OP* o|I32 type poX |OP* |op_lvalue_flags|NULLOK OP* o|I32 type|U32 flags p |void |finalize_optree |NN OP* o @@ -1162,7 +1166,7 @@ Ap |char* |re_intuit_start|NN REGEXP * const rx \ |NULLOK re_scream_pos_data *data Ap |SV* |re_intuit_string|NN REGEXP *const r #if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) -EiPR |I32 |regcurly |NN const char *s +EiPRn |I32 |regcurly |NN const char *s #endif Ap |I32 |regexec_flags |NN REGEXP *const rx|NN char *stringarg \ |NN char *strend|NN char *strbeg \ @@ -1349,7 +1353,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 -Apd |int |sv_backoff |NN SV *const sv +Apdn |int |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 @@ -1568,7 +1572,7 @@ Abmd |UV |to_utf8_fold |NN const U8 *p|NN U8* ustrp|NULLOK STRLEN *lenp AMp |UV |_to_utf8_fold_flags|NN const U8 *p|NN U8* ustrp \ |NULLOK STRLEN *lenp|U8 flags #if defined(PERL_IN_MG_C) || defined(PERL_IN_PP_C) -p |bool |translate_substr_offsets|STRLEN curlen|IV pos1_iv \ +pn |bool |translate_substr_offsets|STRLEN curlen|IV pos1_iv \ |bool pos1_is_uv|IV len_iv \ |bool len_is_uv|NN STRLEN *posp \ |NN STRLEN *lenp @@ -1590,7 +1594,7 @@ Ap |U8* |utf16_to_utf8 |NN U8* p|NN U8 *d|I32 bytelen|NN I32 *newlen Ap |U8* |utf16_to_utf8_reversed|NN U8* p|NN U8 *d|I32 bytelen|NN I32 *newlen AdpPR |STRLEN |utf8_length |NN const U8* s|NN const U8 *e ApdPR |IV |utf8_distance |NN const U8 *a|NN const U8 *b -ApdPR |U8* |utf8_hop |NN const U8 *s|I32 off +ApdPRn |U8* |utf8_hop |NN const U8 *s|I32 off ApMd |U8* |utf8_to_bytes |NN U8 *s|NN STRLEN *len Apd |int |bytes_cmp_utf8 |NN const U8 *b|STRLEN blen|NN const U8 *u \ |STRLEN ulen @@ -2266,7 +2270,9 @@ pX |void |sv_del_backref |NN SV *const tsv|NN SV *const sv #if defined(PERL_IN_SV_C) nsR |char * |uiv_2buf |NN char *const buf|const IV iv|UV uv|const int is_uv|NN char **const peob i |void |sv_unglob |NN SV *const sv|U32 flags +s |const char *|sv_display |NN SV *const sv|NN char *tmpbuf|STRLEN tmpbuf_size s |void |not_a_number |NN SV *const sv +s |void |not_incrementable |NN SV *const sv s |I32 |visit |NN SVFUNC_t f|const U32 flags|const U32 mask # ifdef DEBUGGING s |void |del_sv |NN SV *p @@ -2434,7 +2440,7 @@ Apmd |void |sv_copypv_nomg |NN SV *const dsv|NN SV *const ssv Apd |void |sv_copypv_flags |NN SV *const dsv|NN SV *const ssv|const I32 flags Ap |char* |my_atof2 |NN const char *s|NN NV* value Apn |int |my_socketpair |int family|int type|int protocol|int fd[2] -Ap |int |my_dirfd |NULLOK DIR* dir +Apn |int |my_dirfd |NULLOK DIR* dir #ifdef PERL_ANY_COW : Used in pp_hot.c and regexec.c pMXE |SV* |sv_setsv_cow |NULLOK SV* dstr|NN SV* sstr diff --git a/embed.h b/embed.h index b2863c0..efa1735 100644 --- a/embed.h +++ b/embed.h @@ -77,10 +77,10 @@ #define call_pv(a,b) Perl_call_pv(aTHX_ a,b) #define call_sv(a,b) Perl_call_sv(aTHX_ a,b) #define caller_cx(a,b) Perl_caller_cx(aTHX_ a,b) -#define cast_i32(a) Perl_cast_i32(aTHX_ a) -#define cast_iv(a) Perl_cast_iv(aTHX_ a) -#define cast_ulong(a) Perl_cast_ulong(aTHX_ a) -#define cast_uv(a) Perl_cast_uv(aTHX_ a) +#define cast_i32 Perl_cast_i32 +#define cast_iv Perl_cast_iv +#define cast_ulong Perl_cast_ulong +#define cast_uv Perl_cast_uv #define ck_entersub_args_list(a) Perl_ck_entersub_args_list(aTHX_ a) #define ck_entersub_args_proto(a,b,c) Perl_ck_entersub_args_proto(aTHX_ a,b,c) #define ck_entersub_args_proto_or_list(a,b,c) Perl_ck_entersub_args_proto_or_list(aTHX_ a,b,c) @@ -98,7 +98,7 @@ #define custom_op_desc(a) Perl_custom_op_desc(aTHX_ a) #define custom_op_name(a) Perl_custom_op_name(aTHX_ a) #define cv_clone(a) Perl_cv_clone(aTHX_ a) -#define cv_const_sv(a) Perl_cv_const_sv(aTHX_ a) +#define cv_const_sv Perl_cv_const_sv #define cv_get_call_checker(a,b,c) Perl_cv_get_call_checker(aTHX_ a,b,c) #define cv_set_call_checker(a,b,c) Perl_cv_set_call_checker(aTHX_ a,b,c) #define cv_undef(a) Perl_cv_undef(aTHX_ a) @@ -173,6 +173,7 @@ #define grok_bin(a,b,c,d) Perl_grok_bin(aTHX_ a,b,c,d) #define grok_hex(a,b,c,d) Perl_grok_hex(aTHX_ a,b,c,d) #define grok_number(a,b,c) Perl_grok_number(aTHX_ a,b,c) +#define grok_number_flags(a,b,c,d) Perl_grok_number_flags(aTHX_ a,b,c,d) #define grok_numeric_radix(a,b) Perl_grok_numeric_radix(aTHX_ a,b) #define grok_oct(a,b,c,d) Perl_grok_oct(aTHX_ a,b,c,d) #define gv_add_by_type(a,b) Perl_gv_add_by_type(aTHX_ a,b) @@ -317,22 +318,22 @@ #define mess_sv(a,b) Perl_mess_sv(aTHX_ a,b) #define mg_clear(a) Perl_mg_clear(aTHX_ a) #define mg_copy(a,b,c,d) Perl_mg_copy(aTHX_ a,b,c,d) -#define mg_find(a,b) Perl_mg_find(aTHX_ a,b) -#define mg_findext(a,b,c) Perl_mg_findext(aTHX_ a,b,c) +#define mg_find Perl_mg_find +#define mg_findext Perl_mg_findext #define mg_free(a) Perl_mg_free(aTHX_ a) #define mg_free_type(a,b) Perl_mg_free_type(aTHX_ a,b) #define mg_get(a) Perl_mg_get(aTHX_ a) #define mg_length(a) Perl_mg_length(aTHX_ a) -#define mg_magical(a) Perl_mg_magical(aTHX_ a) +#define mg_magical Perl_mg_magical #define mg_set(a) Perl_mg_set(aTHX_ a) #define mg_size(a) Perl_mg_size(aTHX_ a) -#define mini_mktime(a) Perl_mini_mktime(aTHX_ a) +#define mini_mktime Perl_mini_mktime #define moreswitches(a) Perl_moreswitches(aTHX_ a) #define mro_get_linear_isa(a) Perl_mro_get_linear_isa(aTHX_ a) #define mro_method_changed_in(a) Perl_mro_method_changed_in(aTHX_ a) #define my_atof(a) Perl_my_atof(aTHX_ a) #define my_atof2(a,b) Perl_my_atof2(aTHX_ a,b) -#define my_dirfd(a) Perl_my_dirfd(aTHX_ a) +#define my_dirfd Perl_my_dirfd #define my_exit(a) Perl_my_exit(aTHX_ a) #define my_failure_exit() Perl_my_failure_exit(aTHX) #define my_fflush_all() Perl_my_fflush_all(aTHX) @@ -413,10 +414,12 @@ #define op_free(a) Perl_op_free(aTHX_ a) #define op_linklist(a) Perl_op_linklist(aTHX_ a) #define op_null(a) Perl_op_null(aTHX_ a) +#define op_parent Perl_op_parent #define op_prepend_elem(a,b,c) Perl_op_prepend_elem(aTHX_ a,b,c) #define op_refcnt_lock() Perl_op_refcnt_lock(aTHX) #define op_refcnt_unlock() Perl_op_refcnt_unlock(aTHX) #define op_scope(a) Perl_op_scope(aTHX_ a) +#define op_sibling_splice Perl_op_sibling_splice #define pack_cat(a,b,c,d,e,f,g) Perl_pack_cat(aTHX_ a,b,c,d,e,f,g) #define packlist(a,b,c,d,e) Perl_packlist(aTHX_ a,b,c,d,e) #define pad_add_anon(a,b) Perl_pad_add_anon(aTHX_ a,b) @@ -563,7 +566,7 @@ #define sv_2pvbyte(a,b) Perl_sv_2pvbyte(aTHX_ a,b) #define sv_2pvutf8(a,b) Perl_sv_2pvutf8(aTHX_ a,b) #define sv_2uv_flags(a,b) Perl_sv_2uv_flags(aTHX_ a,b) -#define sv_backoff(a) Perl_sv_backoff(aTHX_ a) +#define sv_backoff Perl_sv_backoff #define sv_bless(a,b) Perl_sv_bless(aTHX_ a,b) #define sv_cat_decode(a,b,c,d,e,f) Perl_sv_cat_decode(aTHX_ a,b,c,d,e,f) #define sv_catpv(a,b) Perl_sv_catpv(aTHX_ a,b) @@ -692,7 +695,7 @@ #define utf16_to_utf8(a,b,c,d) Perl_utf16_to_utf8(aTHX_ a,b,c,d) #define utf16_to_utf8_reversed(a,b,c,d) Perl_utf16_to_utf8_reversed(aTHX_ a,b,c,d) #define utf8_distance(a,b) Perl_utf8_distance(aTHX_ a,b) -#define utf8_hop(a,b) Perl_utf8_hop(aTHX_ a,b) +#define utf8_hop Perl_utf8_hop #define utf8_length(a,b) Perl_utf8_length(aTHX_ a,b) #define utf8_to_bytes(a,b) Perl_utf8_to_bytes(aTHX_ a,b) #define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b) @@ -1015,7 +1018,7 @@ #define grok_bslash_c(a,b) S_grok_bslash_c(aTHX_ a,b) #define grok_bslash_o(a,b,c,d,e,f,g) S_grok_bslash_o(aTHX_ a,b,c,d,e,f,g) #define grok_bslash_x(a,b,c,d,e,f,g) S_grok_bslash_x(aTHX_ a,b,c,d,e,f,g) -#define regcurly(a) S_regcurly(aTHX_ a) +#define regcurly S_regcurly # endif # if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_UTF8_C) #define _add_range_to_invlist(a,b,c) Perl__add_range_to_invlist(aTHX_ a,b,c) @@ -1115,7 +1118,7 @@ #define croak_popstack Perl_croak_popstack #define custom_op_get_field(a,b) Perl_custom_op_get_field(aTHX_ a,b) #define cv_clone_into(a,b) Perl_cv_clone_into(aTHX_ a,b) -#define cv_const_sv_or_av(a) Perl_cv_const_sv_or_av(aTHX_ a) +#define cv_const_sv_or_av Perl_cv_const_sv_or_av #define cv_forget_slab(a) Perl_cv_forget_slab(aTHX_ a) #define cvgv_set(a,b) Perl_cvgv_set(aTHX_ a,b) #define cvstash_set(a,b) Perl_cvstash_set(aTHX_ a,b) @@ -1465,7 +1468,7 @@ #define unwind_handler_stack(a) S_unwind_handler_stack(aTHX_ a) # endif # if defined(PERL_IN_MG_C) || defined(PERL_IN_PP_C) -#define translate_substr_offsets(a,b,c,d,e,f,g) Perl_translate_substr_offsets(aTHX_ a,b,c,d,e,f,g) +#define translate_substr_offsets Perl_translate_substr_offsets # endif # if defined(PERL_IN_MRO_C) #define mro_clean_isarev(a,b,c,d,e,f) S_mro_clean_isarev(aTHX_ a,b,c,d,e,f) @@ -1486,7 +1489,7 @@ #define finalize_op(a) S_finalize_op(aTHX_ a) #define find_and_forget_pmops(a) S_find_and_forget_pmops(aTHX_ a) #define fold_constants(a) S_fold_constants(aTHX_ a) -#define force_list(a) S_force_list(aTHX_ a) +#define force_list(a,b) S_force_list(aTHX_ a,b) #define forget_pmop(a) S_forget_pmop(aTHX_ a) #define gen_constant_list(a) S_gen_constant_list(aTHX_ a) #define gv_ename(a) S_gv_ename(aTHX_ a) @@ -1634,9 +1637,11 @@ #define glob_assign_ref(a,b) S_glob_assign_ref(aTHX_ a,b) #define more_sv() S_more_sv(aTHX) #define not_a_number(a) S_not_a_number(aTHX_ a) +#define not_incrementable(a) S_not_incrementable(aTHX_ a) #define ptr_table_find S_ptr_table_find #define sv_2iuv_common(a) S_sv_2iuv_common(aTHX_ a) #define sv_add_arena(a,b,c) S_sv_add_arena(aTHX_ a,b,c) +#define sv_display(a,b,c) S_sv_display(aTHX_ a,b,c) #define sv_pos_b2u_midway(a,b,c,d) S_sv_pos_b2u_midway(aTHX_ a,b,c,d) #define sv_pos_u2b_cached(a,b,c,d,e,f,g) S_sv_pos_u2b_cached(aTHX_ a,b,c,d,e,f,g) #define sv_pos_u2b_forwards S_sv_pos_u2b_forwards diff --git a/ext/B/B.pm b/ext/B/B.pm index 0259629..c908f51 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.49'; + $B::VERSION = '1.50'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. @@ -1089,6 +1089,11 @@ data structure. See top of C for more info. =item sibling +=item parent + +Returns the OP's parent. If it has no parent, or if your perl wasn't built +with C<-DPERL_OP_PARENT>, returns NULL. + =item name This returns the op name as a string (e.g. "add", "rv2av"). diff --git a/ext/B/B.xs b/ext/B/B.xs index f8e68f6..a130ad3 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -528,7 +528,7 @@ walkoptree(pTHX_ OP *o, const char *method, SV *ref) PUTBACK; perl_call_method(method, G_DISCARD); if (o && (o->op_flags & OPf_KIDS)) { - for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) { + for (kid = ((UNOP*)o)->op_first; kid; kid = OP_SIBLING(kid)) { ref = walkoptree(aTHX_ kid, method, ref); } } @@ -554,7 +554,7 @@ oplist(pTHX_ OP *o, SV **SP) continue; case OP_SORT: if (o->op_flags & OPf_STACKED && o->op_flags & OPf_SPECIAL) { - OP *kid = cLISTOPo->op_first->op_sibling; /* pass pushmark */ + OP *kid = OP_SIBLING(cLISTOPo->op_first); /* pass pushmark */ kid = kUNOP->op_first; /* pass rv2gv */ kid = kUNOP->op_first; /* pass leave */ SP = oplist(aTHX_ kid->op_next, SP); @@ -661,7 +661,7 @@ struct OP_methods { U16 offset; } op_methods[] = { { STR_WITH_LEN("next"), OPp, STRUCT_OFFSET(struct op, op_next), },/* 0*/ - { STR_WITH_LEN("sibling"), OPp, STRUCT_OFFSET(struct op, op_sibling), },/* 1*/ + { STR_WITH_LEN("sibling"), op_offset_special, 0, },/* 1*/ { STR_WITH_LEN("targ"), PADOFFSETp, STRUCT_OFFSET(struct op, op_targ), },/* 2*/ { STR_WITH_LEN("flags"), U8p, STRUCT_OFFSET(struct op, op_flags), },/* 3*/ { STR_WITH_LEN("private"), U8p, STRUCT_OFFSET(struct op, op_private), },/* 4*/ @@ -731,6 +731,8 @@ struct OP_methods { { STR_WITH_LEN("static"), op_offset_special, 0, },/*49*/ # if PERL_VERSION >= 19 { STR_WITH_LEN("folded"), op_offset_special, 0, },/*50*/ + { STR_WITH_LEN("lastsib"), op_offset_special, 0, },/*51*/ + { STR_WITH_LEN("parent"), op_offset_special, 0, },/*52*/ # endif #endif }; @@ -1008,6 +1010,8 @@ next(o) B::OP::savefree = 48 B::OP::static = 49 B::OP::folded = 50 + B::OP::lastsib = 51 + B::OP::parent = 52 PREINIT: SV *ret; PPCODE: @@ -1024,6 +1028,10 @@ next(o) if (op_methods[ix].type == op_offset_special) switch (ix) { + case 1: /* op_sibling */ + ret = make_op_object(aTHX_ OP_SIBLING(o)); + break; + case 8: /* pmreplstart */ ret = make_op_object(aTHX_ cPMOPo->op_type == OP_SUBST @@ -1084,6 +1092,7 @@ next(o) case 49: /* static */ #if PERL_VERSION >= 19 case 50: /* folded */ + case 51: /* lastsib */ #endif #endif /* These are all bitfields, so we can't take their addresses */ @@ -1094,13 +1103,14 @@ next(o) : ix == 48 ? o->op_savefree : ix == 49 ? o->op_static : ix == 50 ? o->op_folded + : ix == 51 ? o->op_lastsib : o->op_spare))); break; case 33: /* children */ { OP *kid; UV i = 0; - for (kid = ((LISTOP*)o)->op_first; kid; kid = kid->op_sibling) + for (kid = ((LISTOP*)o)->op_first; kid; kid = OP_SIBLING(kid)) i++; ret = sv_2mortal(newSVuv(i)); } @@ -1200,6 +1210,9 @@ next(o) sv_setiv(newSVrv(ret, "B::RHE"), PTR2IV(CopHINTHASH_get(cCOPo))); break; + case 52: /* parent */ + ret = make_op_object(aTHX_ op_parent(o)); + break; default: croak("method %s not implemented", op_methods[ix].name); } else { diff --git a/ext/B/t/b.t b/ext/B/t/b.t index 1fee139..27b4105 100644 --- a/ext/B/t/b.t +++ b/ext/B/t/b.t @@ -422,4 +422,23 @@ EOS is($k, "\x{100}", "check utf8 preserved by B::HV::ARRAY"); } +# test op_parent + +SKIP: { + unless ($Config::Config{ccflags} =~ /PERL_OP_PARENT/) { + skip "op_parent only present with -DPERL_OP_PARENT builds", 6; + } + my $lineseq = B::svref_2object(sub{my $x = 1})->ROOT->first; + is ($lineseq->type, B::opnumber('lineseq'), + 'op_parent: top op is lineseq'); + my $first = $lineseq->first; + my $second = $first->sibling; + is(ref $second->sibling, "B::NULL", 'op_parent: second sibling is null'); + is($first->lastsib, 0 , 'op_parent: first sibling: !lastsib'); + is($second->lastsib, 1, 'op_parent: second sibling: lastsib'); + is($$lineseq, ${$first->parent}, 'op_parent: first sibling okay'); + is($$lineseq, ${$second->parent}, 'op_parent: second sibling okay'); +} + + done_testing(); diff --git a/ext/B/t/concise.t b/ext/B/t/concise.t index d43bd97..9a1d1db 100644 --- a/ext/B/t/concise.t +++ b/ext/B/t/concise.t @@ -457,14 +457,14 @@ $out = runperl( switches => ["-MO=Concise,-nobanner,foo"], prog=>'sub foo{}', stderr => 1 ); -unlike $out, 'main::foo', '-nobanner'; +unlike $out, qr/main::foo/, '-nobanner'; # glob $out = runperl( switches => ["-MO=Concise"], prog=>'glob(q{.})', stderr => 1 ); -like $out, '\*::', 'glob(q{.})'; +like $out, qr/\*::/, 'glob(q{.})'; # Test op_other in -debug $out = runperl( @@ -486,7 +486,7 @@ EOF $end =~ s/\r\n/\n/g; -like $out, $end, 'OP_AND has op_other'; +like $out, qr/$end/, 'OP_AND has op_other'; # like(..) above doesn't fill in $1 $out =~ $end; @@ -502,6 +502,6 @@ EOF $end =~ s//$next/; -like $out, $end, 'OP_AND->op_other points correctly'; +like $out, qr/$end/, 'OP_AND->op_other points correctly'; __END__ diff --git a/ext/Devel-Peek/Peek.pm b/ext/Devel-Peek/Peek.pm index d0ed394..c17401b 100644 --- a/ext/Devel-Peek/Peek.pm +++ b/ext/Devel-Peek/Peek.pm @@ -3,7 +3,7 @@ package Devel::Peek; -$VERSION = '1.17'; +$VERSION = '1.18'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/ext/Devel-Peek/Peek.xs b/ext/Devel-Peek/Peek.xs index 0d8b833..49dbea3 100644 --- a/ext/Devel-Peek/Peek.xs +++ b/ext/Devel-Peek/Peek.xs @@ -351,7 +351,7 @@ S_pp_dump(pTHX) static OP * S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv) { - OP *aop, *prev, *first, *second = NULL; + OP *parent, *pm, *first, *second; BINOP *newop; PERL_UNUSED_ARG(cv); @@ -359,13 +359,25 @@ S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv) ck_entersub_args_proto(entersubop, namegv, newSVpvn_flags("$;$", 3, SVs_TEMP)); - aop = cUNOPx(entersubop)->op_first; - if (!aop->op_sibling) - aop = cUNOPx(aop)->op_first; - prev = aop; - aop = aop->op_sibling; - first = aop; - prev->op_sibling = first->op_sibling; + parent = entersubop; + pm = cUNOPx(entersubop)->op_first; + if (!OP_HAS_SIBLING(pm)) { + parent = pm; + pm = cUNOPx(pm)->op_first; + } + first = OP_SIBLING(pm); + second = OP_SIBLING(first); + if (!second) { + /* It doesn’t really matter what we return here, as this only + occurs after yyerror. */ + return entersubop; + } + /* we either have Dump($x): [pushmark]->[first]->[ex-cvop] + * or Dump($x,1); [pushmark]->[first]->[second]->[ex-cvop] + */ + if (!OP_HAS_SIBLING(second)) + second = NULL; + if (first->op_type == OP_RV2AV || first->op_type == OP_PADAV || first->op_type == OP_RV2HV || @@ -374,32 +386,21 @@ S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv) first->op_flags |= OPf_REF; else first->op_flags &= ~OPf_MOD; - aop = aop->op_sibling; - if (!aop) { - /* It doesn’t really matter what we return here, as this only - occurs after yyerror. */ - op_free(first); - return entersubop; - } - /* aop now points to the second arg if there is one, the cvop otherwise - */ - if (aop->op_sibling) { - prev->op_sibling = aop->op_sibling; - second = aop; - second->op_sibling = NULL; - } - first->op_sibling = second; + /* splice out first (and optionally second) ops, then discard the rest + * of the op tree */ + op_sibling_splice(parent, pm, second ? 2 : 1, NULL); op_free(entersubop); + /* then attach first (and second) to a new binop */ + NewOp(1234, newop, 1, BINOP); newop->op_type = OP_CUSTOM; newop->op_ppaddr = S_pp_dump; - newop->op_first = first; - newop->op_last = second; newop->op_private= second ? 2 : 1; newop->op_flags = OPf_KIDS|OPf_WANT_SCALAR; + op_sibling_splice((OP*)newop, NULL, 0, first); return (OP *)newop; } diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 2cfd8a5..0cc6717 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -1030,6 +1030,23 @@ SV = PVAV\($ADDR\) at $ADDR FLAGS = \(IOK,pIOK\) IV = 3 ARRAY + +do_test('Dump @array,1', '@array,1', <<'ARRAY', '', '', 1); +SV = PVAV\($ADDR\) at $ADDR + REFCNT = 1 + FLAGS = \(\) + ARRAY = $ADDR + FILL = 2 + MAX = 3 + ARYLEN = 0x0 + FLAGS = \(REAL\) + Elt No. 0 + SV = IV\($ADDR\) at $ADDR + REFCNT = 1 + FLAGS = \(IOK,pIOK\) + IV = 1 +ARRAY + %hash = 1..2; do_test('Dump %hash', '%hash', <<'HASH', '', '', 1); SV = PVHV\($ADDR\) at $ADDR @@ -1046,6 +1063,7 @@ SV = PVHV\($ADDR\) at $ADDR FLAGS = \(IOK,pIOK\) IV = 2 HASH + $_ = "hello"; do_test('rvalue substr', 'substr $_, 1, 2', <<'SUBSTR', '', '', 1); SV = PV\($ADDR\) at $ADDR @@ -1509,7 +1527,7 @@ dumpindent is 4 at - line 1. { 1 TYPE = leave ===> NULL TARG = 1 - FLAGS = (VOID,KIDS,PARENS,SLABBED) + FLAGS = (VOID,KIDS,PARENS,SLABBED,LASTSIB) PRIVATE = (REFCOUNTED) REFCNT = 1 { @@ -1525,12 +1543,12 @@ dumpindent is 4 at - line 1. { 5 TYPE = entersub ===> 1 TARG = TARGS_REPLACE - FLAGS = (VOID,KIDS,STACKED,SLABBED) + FLAGS = (VOID,KIDS,STACKED,SLABBED,LASTSIB) PRIVATE = (HASTARG) { 6 TYPE = null ===> (5) (was list) - FLAGS = (UNKNOWN,KIDS,SLABBED) + FLAGS = (UNKNOWN,KIDS,SLABBED,LASTSIB) { 4 TYPE = pushmark ===> 7 FLAGS = (SCALAR,SLABBED) @@ -1538,10 +1556,10 @@ dumpindent is 4 at - line 1. { 8 TYPE = null ===> (6) (was rv2cv) - FLAGS = (SCALAR,KIDS,SLABBED) + FLAGS = (SCALAR,KIDS,SLABBED,LASTSIB) { 7 TYPE = gv ===> 5 - FLAGS = (SCALAR,SLABBED) + FLAGS = (SCALAR,SLABBED,LASTSIB) GV_OR_PADIX } } diff --git a/ext/Hash-Util/Util.xs b/ext/Hash-Util/Util.xs index 63d898d..9481dc7 100644 --- a/ext/Hash-Util/Util.xs +++ b/ext/Hash-Util/Util.xs @@ -85,7 +85,7 @@ hash_value(string,...) U8 *seedbuf= (U8 *)SvPV(ST(1),seedlen); if ( seedlen < PERL_HASH_SEED_BYTES ) { sv_dump(ST(1)); - Perl_croak(aTHX_ "seed len must be at least %d long only got %d bytes", PERL_HASH_SEED_BYTES, seedlen); + Perl_croak(aTHX_ "seed len must be at least %d long only got %"UVuf" bytes", PERL_HASH_SEED_BYTES, (UV)seedlen); } PERL_HASH_WITH_SEED(seedbuf, uv, pv, len); @@ -139,7 +139,7 @@ bucket_info(rhv) nothing (the empty list). */ - const HV * hv; + const HV * hv = NULL; if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) { hv = (const HV *) SvRV(rhv); } else if (!SvOK(rhv)) { @@ -199,7 +199,7 @@ bucket_array(rhv) * of the hash store, combined with regular remappings means that relative * order of keys changes each remap. */ - const HV * hv; + const HV * hv = NULL; if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) { hv = (const HV *) SvRV(rhv); } else if (!SvOK(rhv)) { diff --git a/ext/Hash-Util/lib/Hash/Util.pm b/ext/Hash-Util/lib/Hash/Util.pm index 06047b6..da02510 100644 --- a/ext/Hash-Util/lib/Hash/Util.pm +++ b/ext/Hash-Util/lib/Hash/Util.pm @@ -34,7 +34,7 @@ our @EXPORT_OK = qw( hash_traversal_mask ); -our $VERSION = '0.17'; +our $VERSION = '0.18'; require XSLoader; XSLoader::load(); diff --git a/ext/IPC-Open3/lib/IPC/Open3.pm b/ext/IPC-Open3/lib/IPC/Open3.pm index c8620b7..99f120b 100644 --- a/ext/IPC-Open3/lib/IPC/Open3.pm +++ b/ext/IPC-Open3/lib/IPC/Open3.pm @@ -9,7 +9,7 @@ require Exporter; use Carp; use Symbol qw(gensym qualify); -$VERSION = '1.16'; +$VERSION = '1.17'; @ISA = qw(Exporter); @EXPORT = qw(open3); @@ -246,6 +246,7 @@ sub _open3 { # A tie in the parent should not be allowed to cause problems. untie *STDIN; untie *STDOUT; + untie *STDERR; close $stat_r; require Fcntl; diff --git a/ext/IPC-Open3/t/IPC-Open3.t b/ext/IPC-Open3/t/IPC-Open3.t index 6ab519d..fcaecef 100644 --- a/ext/IPC-Open3/t/IPC-Open3.t +++ b/ext/IPC-Open3/t/IPC-Open3.t @@ -14,7 +14,7 @@ BEGIN { } use strict; -use Test::More tests => 38; +use Test::More tests => 44; use IO::Handle; use IPC::Open3; @@ -187,3 +187,34 @@ foreach my $handle (qw (DUMMY STDIN STDOUT STDERR)) { } waitpid $pid, 0; } + +# Test that tied STDIN, STDOUT, and STDERR do not cause open3 any discomfort. +# In particular, tied STDERR used to be able to prevent open3 from working +# correctly. RT #119843. +SKIP: { + if (&IPC::Open3::DO_SPAWN) { + skip "Calling open3 with tied filehandles does not work here", 6 + } + + { # This just throws things out + package My::Tied::FH; + sub TIEHANDLE { bless \my $self } + sub PRINT {} + # Note the absence of OPEN and FILENO + } + my $message = "japh\n"; + foreach my $handle (*STDIN, *STDOUT, *STDERR) { + tie $handle, 'My::Tied::FH'; + my ($in, $out); + my $pid = eval { + open3 $in, $out, undef, $perl, '-ne', 'print'; + }; + is($@, '', "no errors calling open3 with tied $handle"); + print $in $message; + close $in; + my $japh = <$out>; + waitpid $pid, 0; + is($japh, $message, "read input correctly"); + untie $handle; + } +} diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 371db1d..2a77df0 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -986,22 +986,52 @@ localeconv() char * setlocale(category, locale = 0) int category - const char * locale + const char * locale PREINIT: char * retval; CODE: +#ifdef USE_LOCALE_NUMERIC + /* A 0 (or NULL) locale means only query what the current one is. We + * have the LC_NUMERIC name saved, because we are normally switched + * into the C locale for it. Switch back so an LC_ALL query will yield + * the correct results; all other categories don't require special + * handling */ + if (locale == 0) { + if (category == LC_NUMERIC) { + XSRETURN_PV(PL_numeric_name); + } +# ifdef LC_ALL + else if (category == LC_ALL) { + SET_NUMERIC_LOCAL(); + } +# endif + } +#endif #ifdef WIN32 /* Use wrapper on Windows */ retval = Perl_my_setlocale(aTHX_ category, locale); #else retval = setlocale(category, locale); #endif if (! retval) { + /* Should never happen that a query would return an error, but be + * sure and reset to C locale */ + if (locale == 0) { + SET_NUMERIC_STANDARD(); + } XSRETURN_UNDEF; } + + /* Save retval since subsequent setlocale() calls may overwrite it. */ + retval = savepv(retval); + + /* For locale == 0, we may have switched to NUMERIC_LOCAL. Switch back + * */ + if (locale == 0) { + SET_NUMERIC_STANDARD(); + XSRETURN_PV(retval); + } else { - /* Save retval since subsequent setlocale() calls - * may overwrite it. */ - RETVAL = savepv(retval); + RETVAL = retval; #ifdef USE_LOCALE_CTYPE if (category == LC_CTYPE #ifdef LC_ALL diff --git a/ext/POSIX/lib/POSIX.pm b/ext/POSIX/lib/POSIX.pm index 510df22..57845a7 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.40'; +our $VERSION = '1.41'; require XSLoader; diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index e17e263..4fa92e9 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.61'; +our $VERSION = '0.62'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index b9b18f4..54ee2da 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -400,9 +400,9 @@ THX_ck_entersub_args_scalars(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) OP *aop = cUNOPx(entersubop)->op_first; PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(ckobj); - if (!aop->op_sibling) + if (!OP_HAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) { + for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) { op_contextualize(aop, G_SCALAR); } return entersubop; @@ -412,17 +412,20 @@ STATIC OP * THX_ck_entersub_multi_sum(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) { OP *sumop = NULL; + OP *parent = entersubop; OP *pushop = cUNOPx(entersubop)->op_first; PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(ckobj); - if (!pushop->op_sibling) + if (!OP_HAS_SIBLING(pushop)) { + parent = pushop; pushop = cUNOPx(pushop)->op_first; + } while (1) { - OP *aop = pushop->op_sibling; - if (!aop->op_sibling) + OP *aop = OP_SIBLING(pushop); + if (!OP_HAS_SIBLING(aop)) break; - pushop->op_sibling = aop->op_sibling; - aop->op_sibling = NULL; + /* cut out first arg */ + op_sibling_splice(parent, pushop, 1, NULL); op_contextualize(aop, G_SCALAR); if (sumop) { sumop = newBINOP(OP_ADD, 0, sumop, aop); @@ -449,7 +452,7 @@ test_op_list_describe_part(SV *res, OP *o) if (o->op_flags & OPf_KIDS) { OP *k; sv_catpvs(res, "["); - for (k = cUNOPx(o)->op_first; k; k = k->op_sibling) + for (k = cUNOPx(o)->op_first; k; k = OP_SIBLING(k)) test_op_list_describe_part(res, k); sv_catpvs(res, "]"); } else { @@ -476,8 +479,7 @@ THX_mkUNOP(pTHX_ U32 type, OP *first) UNOP *unop; NewOp(1103, unop, 1, UNOP); unop->op_type = (OPCODE)type; - unop->op_first = first; - unop->op_flags = OPf_KIDS; + op_sibling_splice((OP*)unop, NULL, 0, first); return (OP *)unop; } @@ -488,10 +490,8 @@ THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last) BINOP *binop; NewOp(1103, binop, 1, BINOP); binop->op_type = (OPCODE)type; - binop->op_first = first; - binop->op_flags = OPf_KIDS; - binop->op_last = last; - first->op_sibling = last; + op_sibling_splice((OP*)binop, NULL, 0, last); + op_sibling_splice((OP*)binop, NULL, 0, first); return (OP *)binop; } @@ -502,11 +502,9 @@ THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last) LISTOP *listop; NewOp(1103, listop, 1, LISTOP); listop->op_type = (OPCODE)type; - listop->op_flags = OPf_KIDS; - listop->op_first = first; - first->op_sibling = sib; - sib->op_sibling = last; - listop->op_last = last; + op_sibling_splice((OP*)listop, NULL, 0, last); + op_sibling_splice((OP*)listop, NULL, 0, sib); + op_sibling_splice((OP*)listop, NULL, 0, first); return (OP *)listop; } @@ -557,19 +555,21 @@ THX_pp_establish_cleanup(pTHX) STATIC OP * THX_ck_entersub_establish_cleanup(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) { - OP *pushop, *argop, *estop; + OP *parent, *pushop, *argop, *estop; ck_entersub_args_proto(entersubop, namegv, ckobj); + parent = entersubop; pushop = cUNOPx(entersubop)->op_first; - if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first; - argop = pushop->op_sibling; - pushop->op_sibling = argop->op_sibling; - argop->op_sibling = NULL; + if(!OP_HAS_SIBLING(pushop)) { + parent = pushop; + pushop = cUNOPx(pushop)->op_first; + } + /* extract out first arg, then delete the rest of the tree */ + argop = OP_SIBLING(pushop); + op_sibling_splice(parent, pushop, 1, NULL); op_free(entersubop); - NewOpSz(0, estop, sizeof(UNOP)); - estop->op_type = OP_RAND; + + estop = mkUNOP(OP_RAND, argop); estop->op_ppaddr = THX_pp_establish_cleanup; - cUNOPx(estop)->op_flags = OPf_KIDS; - cUNOPx(estop)->op_first = argop; PL_hints |= HINT_BLOCK_SCOPE; return estop; } @@ -577,13 +577,16 @@ THX_ck_entersub_establish_cleanup(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) STATIC OP * THX_ck_entersub_postinc(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) { - OP *pushop, *argop; + OP *parent, *pushop, *argop; ck_entersub_args_proto(entersubop, namegv, ckobj); + parent = entersubop; pushop = cUNOPx(entersubop)->op_first; - if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first; - argop = pushop->op_sibling; - pushop->op_sibling = argop->op_sibling; - argop->op_sibling = NULL; + if(!OP_HAS_SIBLING(pushop)) { + parent = pushop; + pushop = cUNOPx(pushop)->op_first; + } + argop = OP_SIBLING(pushop); + op_sibling_splice(parent, pushop, 1, NULL); op_free(entersubop); return newUNOP(OP_POSTINC, 0, op_lvalue(op_contextualize(argop, G_SCALAR), OP_POSTINC)); @@ -597,12 +600,13 @@ THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) SV *a0, *a1; ck_entersub_args_proto(entersubop, namegv, ckobj); pushop = cUNOPx(entersubop)->op_first; - if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first; - argop = pushop->op_sibling; - if(argop->op_type != OP_CONST || argop->op_sibling->op_type != OP_CONST) + if(!OP_HAS_SIBLING(pushop)) + pushop = cUNOPx(pushop)->op_first; + argop = OP_SIBLING(pushop); + if(argop->op_type != OP_CONST || OP_SIBLING(argop)->op_type != OP_CONST) croak("bad argument expression type for pad_scalar()"); a0 = cSVOPx_sv(argop); - a1 = cSVOPx_sv(argop->op_sibling); + a1 = cSVOPx_sv(OP_SIBLING(argop)); switch(SvIV(a0)) { case 1: { SV *namesv = sv_2mortal(newSVpvs("$")); @@ -690,16 +694,18 @@ static OP *THX_parse_var(pTHX) } #define push_rpn_item(o) \ - (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop) -#define pop_rpn_item() \ - (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \ - (tmpop = stack, stack = stack->op_sibling, \ - tmpop->op_sibling = NULL, tmpop)) + op_sibling_splice(parent, NULL, 0, o); +#define pop_rpn_item() ( \ + (tmpop = op_sibling_splice(parent, NULL, 1, NULL)) \ + ? tmpop : (croak("RPN stack underflow"), (OP*)NULL)) #define parse_rpn_expr() THX_parse_rpn_expr(aTHX) static OP *THX_parse_rpn_expr(pTHX) { - OP *stack = NULL, *tmpop; + OP *tmpop; + /* fake parent for splice to mess with */ + OP *parent = mkBINOP(OP_NULL, NULL, NULL); + while(1) { I32 c; lex_read_space(0); @@ -707,7 +713,9 @@ static OP *THX_parse_rpn_expr(pTHX) switch(c) { case /*(*/')': case /*{*/'}': { OP *result = pop_rpn_item(); - if(stack) croak("RPN expression must return a single value"); + if(cLISTOPx(parent)->op_first) + croak("RPN expression must return a single value"); + op_free(parent); return result; } break; case '0': case '1': case '2': case '3': case '4': @@ -1091,14 +1099,14 @@ addissub_myck_add(pTHX_ OP *op) OP *aop, *bop; U8 flags; if (!(flag_svp && SvTRUE(*flag_svp) && (op->op_flags & OPf_KIDS) && - (aop = cBINOPx(op)->op_first) && (bop = aop->op_sibling) && - !bop->op_sibling)) + (aop = cBINOPx(op)->op_first) && (bop = OP_SIBLING(aop)) && + !OP_HAS_SIBLING(bop))) return addissub_nxck_add(aTHX_ op); - aop->op_sibling = NULL; - cBINOPx(op)->op_first = NULL; - op->op_flags &= ~OPf_KIDS; flags = op->op_flags; - op_free(op); + op_sibling_splice(op, NULL, 1, NULL); /* excise aop */ + op_sibling_splice(op, NULL, 1, NULL); /* excise bop */ + op_free(op); /* free the empty husk */ + flags &= ~OPf_KIDS; return newBINOP(OP_SUBTRACT, flags, aop, bop); } @@ -1732,12 +1740,9 @@ xop_build_optree () kid = newSVOP(OP_CONST, 0, newSViv(42)); - NewOp(1102, unop, 1, UNOP); - unop->op_type = OP_CUSTOM; + unop = (UNOP*)mkUNOP(OP_CUSTOM, kid); unop->op_ppaddr = pp_xop; - unop->op_flags = OPf_KIDS; unop->op_private = 0; - unop->op_first = kid; unop->op_next = NULL; kid->op_next = (OP*)unop; @@ -1766,12 +1771,9 @@ xop_from_custom_op () UNOP *unop; XOP *xop; - NewOp(1102, unop, 1, UNOP); - unop->op_type = OP_CUSTOM; + unop = (UNOP*)mkUNOP(OP_CUSTOM, NULL); unop->op_ppaddr = pp_xop; - unop->op_flags = OPf_KIDS; unop->op_private = 0; - unop->op_first = NULL; unop->op_next = NULL; xop = Perl_custom_op_xop(aTHX_ (OP *)unop); @@ -3646,7 +3648,7 @@ test_get_vtbl() MGVTBL *want; CODE: #define test_get_this_vtable(name) \ - want = CAT2(&PL_vtbl_, name); \ + want = (MGVTBL*)CAT2(&PL_vtbl_, name); \ have = get_vtbl(CAT2(want_vtbl_, name)); \ if (have != want) \ croak("fail %p!=%p for get_vtbl(want_vtbl_" STRINGIFY(name) ") at " __FILE__ " line %d", have, want, __LINE__) diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL index 031ce8a..173e5c9 100644 --- a/ext/XS-APItest/Makefile.PL +++ b/ext/XS-APItest/Makefile.PL @@ -24,7 +24,7 @@ my @names = (qw(HV_DELETE HV_DISABLE_UVAR_XKEY HV_FETCH_ISSTORE G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL IS_NUMBER_IN_UV IS_NUMBER_GREATER_THAN_UV_MAX IS_NUMBER_NOT_INT IS_NUMBER_NEG IS_NUMBER_INFINITY - IS_NUMBER_NAN + IS_NUMBER_NAN IS_NUMBER_TRAILING PERL_SCAN_TRAILING ), {name=>"G_WANT", default=>["IV", "G_ARRAY|G_VOID"]}); diff --git a/ext/XS-APItest/numeric.xs b/ext/XS-APItest/numeric.xs index b06258d..ab48dba 100644 --- a/ext/XS-APItest/numeric.xs +++ b/ext/XS-APItest/numeric.xs @@ -14,3 +14,19 @@ grok_number(number) PUSHs(sv_2mortal(newSViv(result))); if (result & IS_NUMBER_IN_UV) PUSHs(sv_2mortal(newSVuv(value))); + +void +grok_number_flags(number, flags) + SV *number + U32 flags + PREINIT: + STRLEN len; + const char *pv = SvPV(number, len); + UV value; + int result; + PPCODE: + EXTEND(SP,2); + result = grok_number_flags(pv, len, &value, flags); + PUSHs(sv_2mortal(newSViv(result))); + if (result & IS_NUMBER_IN_UV) + PUSHs(sv_2mortal(newSVuv(value))); diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t index 54f45ec..9ab633d 100644 --- a/ext/XS-APItest/t/call.t +++ b/ext/XS-APItest/t/call.t @@ -279,7 +279,7 @@ for my $fn_type (0..2) { # 0:eval_pv 1:eval_sv 2:call_sv } else { is($warn_msg, undef, "$desc - __WARN__ not called"); - unlike($@, 'pre-err', "$desc - \$@ modified"); + unlike($@, qr/pre-err/, "$desc - \$@ modified"); } like($@, ( diff --git a/ext/XS-APItest/t/callregexec.t b/ext/XS-APItest/t/callregexec.t index 3111390..74e1e20 100644 --- a/ext/XS-APItest/t/callregexec.t +++ b/ext/XS-APItest/t/callregexec.t @@ -42,7 +42,10 @@ sub try { try "ax", qr/a$/m, 1, 'MEOL'; try "ax", qr/a$/s, 1, 'SEOL'; try "abx", qr/^(ab|X)./s, 0, 'SANY'; - try "abx", qr/^(ab|X)\C/, 0, 'CANY'; + { + no warnings 'deprecated'; + try "abx", qr/^(ab|X)\C/, 0, 'CANY'; + } try "abx", qr/^(ab|X)./, 0, 'REG_ANY'; try "abx", qr/^ab(c|d|e|x)/, 0, 'TRIE/TRIEC'; try "abx", qr/^abx/, 0, 'EXACT'; diff --git a/ext/XS-APItest/t/grok.t b/ext/XS-APItest/t/grok.t index 99fbc5d..2e035ee 100644 --- a/ext/XS-APItest/t/grok.t +++ b/ext/XS-APItest/t/grok.t @@ -74,4 +74,39 @@ foreach my $leader ('', ' ', ' ') { } } +# format tests +my @groks = + ( + # input, in flags, out uv, out flags + [ "1", 0, 1, IS_NUMBER_IN_UV ], + [ "1x", 0, undef, 0 ], + [ "1x", PERL_SCAN_TRAILING, 1, IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ], + [ "3.1", 0, 3, IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT ], + [ "3.1a", 0, undef, 0 ], + [ "3.1a", PERL_SCAN_TRAILING, 3, + IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], + [ "3e5", 0, undef, IS_NUMBER_NOT_INT ], + [ "3e", 0, undef, 0 ], + [ "3e", PERL_SCAN_TRAILING, 3, IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ], + [ "3e+", 0, undef, 0 ], + [ "3e+", PERL_SCAN_TRAILING, 3, IS_NUMBER_IN_UV | IS_NUMBER_TRAILING ], + [ "Inf", 0, undef, + IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT ], + [ "In", 0, undef, 0 ], + [ "Infin",0, undef, 0 ], + # this doesn't work and hasn't been needed yet + #[ "Infin",PERL_SCAN_TRAILING, undef, + # IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], + [ "nan", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ], + [ "nanx", 0, undef, 0 ], + [ "nanx", PERL_SCAN_TRAILING, undef, + IS_NUMBER_NAN | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING], + ); + +for my $grok (@groks) { + my ($out_flags, $out_uv) = grok_number_flags($grok->[0], $grok->[1]); + is($out_uv, $grok->[2], "'$grok->[0]' flags $grok->[1] - check number"); + is($out_flags, $grok->[3], "'$grok->[0]' flags $grok->[1] - check flags"); +} + done_testing(); diff --git a/ext/arybase/arybase.pm b/ext/arybase/arybase.pm index 3c090d6..67c71e7 100644 --- a/ext/arybase/arybase.pm +++ b/ext/arybase/arybase.pm @@ -1,6 +1,6 @@ package arybase; -our $VERSION = "0.07"; +our $VERSION = "0.08"; require XSLoader; XSLoader::load(); # This returns true, which makes require happy. diff --git a/ext/arybase/arybase.xs b/ext/arybase/arybase.xs index f8f9ce2..a44233d 100644 --- a/ext/arybase/arybase.xs +++ b/ext/arybase/arybase.xs @@ -156,7 +156,8 @@ STATIC void ab_neuter_dollar_bracket(pTHX_ OP *o) { oldc = cUNOPx(o)->op_first; newc = newGVOP(OP_GV, 0, gv_fetchpvs("arybase::leftbrack", GV_ADDMULTI, SVt_PVGV)); - cUNOPx(o)->op_first = newc; + /* replace oldc with newc */ + op_sibling_splice(o, NULL, 1, newc); op_free(oldc); } @@ -176,7 +177,7 @@ STATIC OP *ab_ck_sassign(pTHX_ OP *o) { o = (*ab_old_ck_sassign)(aTHX_ o); if (o->op_type == OP_SASSIGN && FEATURE_ARYBASE_IS_ENABLED) { OP *right = cBINOPx(o)->op_first; - OP *left = right->op_sibling; + OP *left = OP_SIBLING(right); if (left) ab_process_assignment(left, right); } return o; @@ -186,8 +187,9 @@ STATIC OP *ab_ck_aassign(pTHX_ OP *o) { o = (*ab_old_ck_aassign)(aTHX_ o); if (o->op_type == OP_AASSIGN && FEATURE_ARYBASE_IS_ENABLED) { OP *right = cBINOPx(o)->op_first; - OP *left = cBINOPx(right->op_sibling)->op_first->op_sibling; - right = cBINOPx(right)->op_first->op_sibling; + OP *left = OP_SIBLING(right); + left = OP_SIBLING(cBINOPx(left)->op_first); + right = OP_SIBLING(cBINOPx(right)->op_first); ab_process_assignment(left, right); } return o; @@ -375,10 +377,17 @@ static OP *ab_ck_base(pTHX_ OP *o) ab_map_store(o, o->op_ppaddr, base); o->op_ppaddr = new_pp; /* Break the aelemfast optimisation */ - if (o->op_type == OP_AELEM && - cBINOPo->op_first->op_sibling->op_type == OP_CONST) { - cBINOPo->op_first->op_sibling - = newUNOP(OP_NULL,0,cBINOPo->op_first->op_sibling); + if (o->op_type == OP_AELEM) { + OP *const first = cBINOPo->op_first; + OP *second = OP_SIBLING(first); + OP *newop; + if (second->op_type == OP_CONST) { + /* cut out second arg and replace it with a new unop which is + * the parent of that arg */ + op_sibling_splice(o, first, 1, NULL); + newop = newUNOP(OP_NULL,0,second); + op_sibling_splice(o, first, 0, newop); + } } } else ab_map_delete(o); diff --git a/gv.c b/gv.c index 1ef1155..64bdbf1 100644 --- a/gv.c +++ b/gv.c @@ -101,7 +101,6 @@ GV * Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, const U32 flags) { - dVAR; char smallbuf[128]; char *tmpbuf; const STRLEN tmplen = namelen + 2; @@ -152,6 +151,7 @@ SV * Perl_gv_const_sv(pTHX_ GV *gv) { PERL_ARGS_ASSERT_GV_CONST_SV; + PERL_UNUSED_CONTEXT; if (SvTYPE(gv) == SVt_PVGV) return cv_const_sv(GvCVu(gv)); @@ -329,7 +329,6 @@ Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags) void Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags) { - dVAR; const U32 old_type = SvTYPE(gv); const bool doproto = old_type > SVt_NULL; char * const proto = (doproto && SvPOK(gv)) @@ -644,7 +643,6 @@ obtained from the GV with the C macro. GV * Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags) { - dVAR; GV** gvp; AV* linear_av; SV** linear_svp; @@ -947,7 +945,6 @@ Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags) GV * Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags) { - dVAR; const char *nend; const char *nsplit = NULL; GV* gv; @@ -1097,7 +1094,6 @@ Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags) GV* Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) { - dVAR; GV* gv; CV* cv; HV* varstash; @@ -1245,7 +1241,6 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) STATIC HV* S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags) { - dVAR; HV* stash = gv_stashsv(namesv, 0); PERL_ARGS_ASSERT_REQUIRE_TIE_MOD; @@ -2083,7 +2078,6 @@ GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const svtype sv_type) { - dVAR; const char *name = nambeg; GV *gv = NULL; GV**gvp; @@ -2261,7 +2255,6 @@ Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain void Perl_gv_check(pTHX_ HV *stash) { - dVAR; I32 i; PERL_ARGS_ASSERT_GV_CHECK; @@ -2315,7 +2308,6 @@ Perl_gv_check(pTHX_ HV *stash) GV * Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags) { - dVAR; PERL_ARGS_ASSERT_NEWGVGEN_FLAGS; assert(!(flags & ~SVf_UTF8)); @@ -2330,7 +2322,6 @@ Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags) GP* Perl_gp_ref(pTHX_ GP *gp) { - dVAR; if (!gp) return NULL; gp->gp_refcnt++; @@ -2350,7 +2341,6 @@ Perl_gp_ref(pTHX_ GP *gp) void Perl_gp_free(pTHX_ GV *gv) { - dVAR; GP* gp; int attempts = 100; @@ -2464,7 +2454,6 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) int Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) { - dVAR; MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); AMT amt; const struct mro_meta* stash_meta = HvMROMETA(stash); @@ -2632,7 +2621,6 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) CV* Perl_gv_handler(pTHX_ HV *stash, I32 id) { - dVAR; MAGIC *mg; AMT *amtp; U32 newgen; @@ -2684,7 +2672,6 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) bool Perl_try_amagic_un(pTHX_ int method, int flags) { - dVAR; dSP; SV* tmpsv; SV* const arg = TOPs; @@ -2727,7 +2714,6 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { bool Perl_try_amagic_bin(pTHX_ int method, int flags) { - dVAR; dSP; SV* const left = TOPm1s; SV* const right = TOPs; diff --git a/hints/catamount.sh b/hints/catamount.sh index be90130..0d8f813 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.21.1 +# mkdir -p /opt/perl-catamount/lib/perl5/5.21.2 # 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.21.1 +# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.21.2 # 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/hv.c b/hv.c index 5a975ed..5bab2d7 100644 --- a/hv.c +++ b/hv.c @@ -50,7 +50,6 @@ static const char S_strtab_error[] STATIC HE* S_new_he(pTHX) { - dVAR; HE* he; void ** const root = &PL_body_roots[HE_SVSLOT]; @@ -101,7 +100,6 @@ S_save_hek_flags(const char *str, I32 len, U32 hash, int flags) void Perl_free_tied_hv_pool(pTHX) { - dVAR; HE *he = PL_hv_fetch_ent_mh; while (he) { HE * const ohe = he; @@ -347,6 +345,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, bool is_utf8; int masked_flags; const int return_svp = action & HV_FETCH_JUST_SV; + HEK *keysv_hek = NULL; if (!hv) return NULL; @@ -616,12 +615,13 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } } - if (!hash) { - if (keysv && (SvIsCOW_shared_hash(keysv))) - hash = SvSHARED_HASH(keysv); - else - PERL_HASH(hash, key, klen); + if (keysv && (SvIsCOW_shared_hash(keysv))) { + if (HvSHAREKEYS(hv)) + keysv_hek = SvSHARED_HEK_FROM_PV(SvPVX_const(keysv)); + hash = SvSHARED_HASH(keysv); } + else if (!hash) + PERL_HASH(hash, key, klen); masked_flags = (flags & HVhek_MASK); @@ -632,16 +632,48 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, { entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; } + + if (!entry) + goto not_found; + + if (keysv_hek) { + /* keysv is actually a HEK in disguise, so we can match just by + * comparing the HEK pointers in the HE chain. There is a slight + * caveat: on something like "\x80", which has both plain and utf8 + * representations, perl's hashes do encoding-insensitive lookups, + * but preserve the encoding of the stored key. Thus a particular + * key could map to two different HEKs in PL_strtab. We only + * conclude 'not found' if all the flags are the same; otherwise + * we fall back to a full search (this should only happen in rare + * cases). + */ + int keysv_flags = HEK_FLAGS(keysv_hek); + HE *orig_entry = entry; + + for (; entry; entry = HeNEXT(entry)) { + HEK *hek = HeKEY_hek(entry); + if (hek == keysv_hek) + goto found; + if (HEK_FLAGS(hek) != keysv_flags) + break; /* need to do full match */ + } + if (!entry) + goto not_found; + /* failed on shortcut - do full search loop */ + entry = orig_entry; + } + for (; entry; entry = HeNEXT(entry)) { if (HeHASH(entry) != hash) /* strings can't be equal */ continue; if (HeKLEN(entry) != (I32)klen) continue; - if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ + if (memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) continue; + found: if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) { if (HeKFLAGS(entry) != masked_flags) { /* We match if HVhek_UTF8 bit in our flags and hash key's @@ -710,6 +742,8 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } return entry; } + + not_found: #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ if (!(action & HV_FETCH_ISSTORE) && SvRMAGICAL((const SV *)hv) @@ -957,9 +991,14 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, XPVHV* xhv; HE *entry; HE **oentry; - HE *const *first_entry; + HE **first_entry; bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE; int masked_flags; + HEK *keysv_hek = NULL; + U8 mro_changes = 0; /* 1 = isa; 2 = package moved */ + SV *sv; + GV *gv = NULL; + HV *stash = NULL; if (SvRMAGICAL(hv)) { bool needs_copy; @@ -1024,32 +1063,60 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, HvHASKFLAGS_on(MUTABLE_SV(hv)); } - if (!hash) { - if (keysv && (SvIsCOW_shared_hash(keysv))) - hash = SvSHARED_HASH(keysv); - else - PERL_HASH(hash, key, klen); + if (keysv && (SvIsCOW_shared_hash(keysv))) { + if (HvSHAREKEYS(hv)) + keysv_hek = SvSHARED_HEK_FROM_PV(SvPVX_const(keysv)); + hash = SvSHARED_HASH(keysv); } + else if (!hash) + PERL_HASH(hash, key, klen); masked_flags = (k_flags & HVhek_MASK); first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; entry = *oentry; - for (; entry; oentry = &HeNEXT(entry), entry = *oentry) { - SV *sv; - U8 mro_changes = 0; /* 1 = isa; 2 = package moved */ - GV *gv = NULL; - HV *stash = NULL; + if (!entry) + goto not_found; + + if (keysv_hek) { + /* keysv is actually a HEK in disguise, so we can match just by + * comparing the HEK pointers in the HE chain. There is a slight + * caveat: on something like "\x80", which has both plain and utf8 + * representations, perl's hashes do encoding-insensitive lookups, + * but preserve the encoding of the stored key. Thus a particular + * key could map to two different HEKs in PL_strtab. We only + * conclude 'not found' if all the flags are the same; otherwise + * we fall back to a full search (this should only happen in rare + * cases). + */ + int keysv_flags = HEK_FLAGS(keysv_hek); + + for (; entry; oentry = &HeNEXT(entry), entry = *oentry) { + HEK *hek = HeKEY_hek(entry); + if (hek == keysv_hek) + goto found; + if (HEK_FLAGS(hek) != keysv_flags) + break; /* need to do full match */ + } + if (!entry) + goto not_found; + /* failed on shortcut - do full search loop */ + oentry = first_entry; + entry = *oentry; + } + + for (; entry; oentry = &HeNEXT(entry), entry = *oentry) { if (HeHASH(entry) != hash) /* strings can't be equal */ continue; if (HeKLEN(entry) != (I32)klen) continue; - if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ + if (memNE(HeKEY(entry),key,klen)) /* is this it? */ continue; if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) continue; + found: if (hv == PL_strtab) { if (k_flags & HVhek_FREEKEY) Safefree(key); @@ -1150,6 +1217,8 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return sv; } + + not_found: if (SvREADONLY(hv)) { hv_notallowed(k_flags, key, klen, "Attempt to delete disallowed key '%"SVf"' from" @@ -1165,7 +1234,6 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, STATIC void S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize) { - dVAR; STRLEN i = 0; char *a = (char*) HvARRAY(hv); HE **aep; @@ -1289,7 +1357,6 @@ S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize) void Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) { - dVAR; XPVHV* xhv = (XPVHV*)SvANY(hv); const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */ I32 newsize; @@ -1475,7 +1542,6 @@ Perl_hv_copy_hints_hv(pTHX_ HV *const ohv) STATIC SV* S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry) { - dVAR; SV *val; PERL_ARGS_ASSERT_HV_FREE_ENT_RET; @@ -1497,7 +1563,6 @@ S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry) void Perl_hv_free_ent(pTHX_ HV *hv, HE *entry) { - dVAR; SV *val; PERL_ARGS_ASSERT_HV_FREE_ENT; @@ -1512,8 +1577,6 @@ Perl_hv_free_ent(pTHX_ HV *hv, HE *entry) void Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry) { - dVAR; - PERL_ARGS_ASSERT_HV_DELAYFREE_ENT; if (!entry) @@ -1609,7 +1672,6 @@ See Hash::Util::lock_keys() for an example of its use. void Perl_hv_clear_placeholders(pTHX_ HV *hv) { - dVAR; const U32 items = (U32)HvPLACEHOLDERS_get(hv); PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS; @@ -1778,7 +1840,6 @@ See also L. void Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) { - dVAR; XPVHV* xhv; bool save; @@ -2322,7 +2383,6 @@ This is called when a stash is deleted from the symbol table. void Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags) { - dVAR; struct xpvhv_aux *aux; PERL_ARGS_ASSERT_HV_ENAME_DELETE; @@ -2390,7 +2450,6 @@ Perl_hv_backreferences_p(pTHX_ HV *hv) { struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv); PERL_ARGS_ASSERT_HV_BACKREFERENCES_P; - PERL_UNUSED_CONTEXT; return &(iter->xhv_backreferences); } @@ -2725,7 +2784,6 @@ Perl_unshare_hek(pTHX_ HEK *hek) STATIC void S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) { - dVAR; XPVHV* xhv; HE *entry; HE **oentry; @@ -2848,7 +2906,6 @@ Perl_share_hek(pTHX_ const char *str, I32 len, U32 hash) STATIC HEK * S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) { - dVAR; HE *entry; const int flags_masked = flags & HVhek_MASK; const U32 hindex = hash & (I32) HvMAX(PL_strtab); @@ -2933,7 +2990,6 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) SSize_t * Perl_hv_placeholders_p(pTHX_ HV *hv) { - dVAR; MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash); PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P; @@ -2952,10 +3008,10 @@ Perl_hv_placeholders_p(pTHX_ HV *hv) I32 Perl_hv_placeholders_get(pTHX_ const HV *hv) { - dVAR; MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash); PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET; + PERL_UNUSED_CONTEXT; return mg ? mg->mg_len : 0; } @@ -2963,7 +3019,6 @@ Perl_hv_placeholders_get(pTHX_ const HV *hv) void Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph) { - dVAR; MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash); PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET; @@ -3462,7 +3517,9 @@ no action occurs in this case. void Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) { +#ifdef USE_ITHREADS dVAR; +#endif PERL_UNUSED_CONTEXT; while (he) { @@ -3499,7 +3556,9 @@ to this function: no action occurs and a null pointer is returned. struct refcounted_he * Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he) { +#ifdef USE_ITHREADS dVAR; +#endif PERL_UNUSED_CONTEXT; if (he) { HINTS_REFCNT_LOCK; diff --git a/inline.h b/inline.h index 8b74452..0792694 100644 --- a/inline.h +++ b/inline.h @@ -189,7 +189,7 @@ S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp) /* saves machine code for a common noreturn idiom typically used in Newx*() */ #ifdef GCC_DIAG_PRAGMA -GCC_DIAG_IGNORE(-Wunused-function); +GCC_DIAG_IGNORE(-Wunused-function) /* Intentionally left semicolonless. */ #endif static void S_croak_memory_wrap(void) @@ -197,7 +197,7 @@ S_croak_memory_wrap(void) Perl_croak_nocontext("%s",PL_memory_wrap); } #ifdef GCC_DIAG_PRAGMA -GCC_DIAG_RESTORE; +GCC_DIAG_RESTORE /* Intentionally left semicolonless. */ #endif /* ------------------------------- utf8.h ------------------------------- */ diff --git a/intrpvar.h b/intrpvar.h index c8982fd..77926df 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -171,7 +171,7 @@ PERLVAR(I, statgv, GV *) PERLVARI(I, statname, SV *, NULL) #ifdef HAS_TIMES -/* Will be removed soon after v5.21.1. See RT #121351 */ +/* Will be removed soon after v5.21.2. See RT #121351 */ PERLVAR(I, timesbuf, struct tms) #endif @@ -733,7 +733,7 @@ PERLVAR(I, debug_pad, struct perl_debug_pad) /* always needed because of the re /* Hook for File::Glob */ PERLVARI(I, globhook, globhook_t, NULL) -/* The last unconditional member of the interpreter structure when 5.21.1 was +/* The last unconditional member of the interpreter structure when 5.21.2 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/keywords.c b/keywords.c index cd8a99e..8c5e8bf 100644 --- a/keywords.c +++ b/keywords.c @@ -13,8 +13,6 @@ I32 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) { - dVAR; - PERL_ARGS_ASSERT_KEYWORD; switch (len) @@ -3439,5 +3437,5 @@ unknown: } /* Generated from: - * 7c6d47fd2890b2422a40331ec90eac08f9808209b01f2b9c113141410fea91b5 regen/keywords.pl + * 963511f90d23994583c88b07c3cf2258473567702972e94b59a635727c4aa944 regen/keywords.pl * ex: set ro: */ diff --git a/keywords.h b/keywords.h index f23896c..faf1125 100644 --- a/keywords.h +++ b/keywords.h @@ -270,5 +270,5 @@ #define KEY_y 254 /* Generated from: - * 7c6d47fd2890b2422a40331ec90eac08f9808209b01f2b9c113141410fea91b5 regen/keywords.pl + * 963511f90d23994583c88b07c3cf2258473567702972e94b59a635727c4aa944 regen/keywords.pl * ex: set ro: */ diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index a20a964..95fb4e1 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -22,7 +22,7 @@ sub syscopy; sub cp; sub mv; -$VERSION = '2.29'; +$VERSION = '2.30'; require Exporter; @ISA = qw(Exporter); @@ -370,6 +370,7 @@ written to. If the second argument does not exist but the parent directory does exist, then it will be created. Trying to copy a file into a non-existent directory is an error. Trying to copy a file on top of itself is also an error. +C will not overwrite read-only files. If the destination (second argument) already exists and is a directory, and the source (first argument) is not a filehandle, then the source diff --git a/lib/charnames.t b/lib/charnames.t index 5629f3a..bd0c21e 100644 --- a/lib/charnames.t +++ b/lib/charnames.t @@ -41,7 +41,7 @@ use charnames ":full"; 1 EOE - like($@, "above 0xFF", "Verify get warning for \\N{above ff} under 'use bytes' with :full"); + like($@, qr/above 0xFF/, "Verify get warning for \\N{above ff} under 'use bytes' with :full"); ok(! defined $res, "... and result is undefined"); $res = eval <<'EOE'; @@ -49,7 +49,7 @@ use charnames 'cyrillic'; "Here: \N{Be}!"; 1 EOE - like($@, "CYRILLIC CAPITAL LETTER BE.*above 0xFF", "Verify get warning under 'use bytes' with explicit script"); + like($@, qr/CYRILLIC CAPITAL LETTER BE.*above 0xFF/, "Verify get warning under 'use bytes' with explicit script"); ok(! defined $res, "... and result is undefined"); $res = eval <<'EOE'; diff --git a/lib/diagnostics.t b/lib/diagnostics.t index 7c04342..4ac2ebf 100644 --- a/lib/diagnostics.t +++ b/lib/diagnostics.t @@ -134,15 +134,12 @@ like $warning, 'spaces in warnings with periods at the end are matched lightly'; # Wrapped links -SKIP: { -skip("We no longer have any multi-line links", 1); seek STDERR, 0,0; $warning = ''; warn "Argument \"%s\" treated as 0 in increment (++)"; like $warning, qr/Auto-increment.*Auto-decrement/s, 'multiline links are not truncated'; -} { # Find last warning in perldiag.pod, and last items if any diff --git a/lib/locale.t b/lib/locale.t index 2d668c4..31b40f9 100644 --- a/lib/locale.t +++ b/lib/locale.t @@ -917,12 +917,7 @@ foreach my $Locale (@Locale) { debug "is utf8 locale? = $is_utf8_locale\n"; - my $radix = localeconv()->{decimal_point}; - if ($radix !~ / ^ [[:ascii:]] + $/x) { - use bytes; - $radix = disp_chars(split "", $radix); - } - debug "radix = $radix\n"; + debug "radix = " . disp_str(localeconv()->{decimal_point}) . "\n"; if (! $is_utf8_locale) { use locale; @@ -2228,12 +2223,14 @@ foreach $test_num ($first_locales_test_number..$final_locales_test_number) { print "# problem is not likely to be Perl's\n"; } } - elsif ($debug) { + if ($debug) { print "# $percent_fail% of locales (", scalar(keys $Problem{$test_num}), " of ", scalar(@Locale), - ") fail the following test\n"; + ") fail the above test (TODO cut-off is ", + $acceptable_failure_percentage, + "%)\n"; } } print "#\n"; diff --git a/lib/overload.t b/lib/overload.t index 7efd992..d89ec2a 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -305,7 +305,7 @@ is($na, '_!_xx_!_'); $na = 0; $na = eval { ~$aI }; -like($@, ''); +is($@, ''); bless \$x, OscalarI; diff --git a/lib/perl5db.t b/lib/perl5db.t index bd5615a..e93aee0 100644 --- a/lib/perl5db.t +++ b/lib/perl5db.t @@ -92,29 +92,29 @@ EOF { local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1"; my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110'); - like($output, "All tests successful.", "[perl #66110]"); + like($output, qr/\bAll tests successful\.$/, "[perl #66110]"); } # [ perl #116769] Frame=2 { local $ENV{PERLDB_OPTS} = "frame=2 nonstop"; - my $output = runperl( switches => [ '-d' ], prog => 'print q{success}' ); + my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' ); is( $?, 0, '[perl #116769] frame=2 does not crash debugger, exit == 0' ); - like( $output, 'success' , '[perl #116769] code is run' ); + is( $output, "success\n" , '[perl #116769] code is run' ); } # [ perl #116771] autotrace { local $ENV{PERLDB_OPTS} = "autotrace nonstop"; - my $output = runperl( switches => [ '-d' ], prog => 'print q{success}' ); + my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' ); is( $?, 0, '[perl #116771] autotrace does not crash debugger, exit == 0' ); - like( $output, 'success' , '[perl #116771] code is run' ); + is( $output, "success\n" , '[perl #116771] code is run' ); } # [ perl #41461] Frame=2 noTTY { local $ENV{PERLDB_OPTS} = "frame=2 noTTY nonstop"; rc(''); - my $output = runperl( switches => [ '-d' ], prog => 'print q{success}' ); + my $output = runperl( switches => [ '-d' ], prog => 'print qq{success\n}' ); is( $?, 0, '[perl #41461] frame=2 noTTY does not crash debugger, exit == 0' ); - like( $output, 'success' , '[perl #41461] code is run' ); + is( $output, "success\n" , '[perl #41461] code is run' ); } package DebugWrap; diff --git a/lib/warnings.pm b/lib/warnings.pm index 37e6e56..a08be18 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -5,7 +5,7 @@ package warnings; -our $VERSION = '1.24'; +our $VERSION = '1.26'; # Verify that we're called correctly so that warnings will work. # see also strict.pm. @@ -301,6 +301,8 @@ The current hierarchy is: | +- misc | + +- missing + | +- numeric | +- once @@ -315,6 +317,8 @@ The current hierarchy is: | +- redefine | + +- redundant + | +- regexp | +- severe --------+ @@ -396,6 +400,10 @@ Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a sub-category of the "syntax" category. It is now a top-level category in its own right. +Note: Before 5.21.0, the "missing" lexical warnings category was +internally defined to be the same as the "uninitialized" category. It +is now a top-level category in its own right. + =head2 Fatal Warnings X @@ -818,10 +826,12 @@ our %Offsets = ( # Warnings Categories added in Perl 5.021 'experimental::win32_perlio'=> 120, + 'missing' => 122, + 'redundant' => 124, ); our %Bits = ( - 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x01", # [0..60] + 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..62] 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\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", # [30] 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] @@ -849,6 +859,7 @@ our %Bits = ( 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\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", # [12] + 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [61] 'newline' => "\x00\x00\x04\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", # [48] 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [49] @@ -865,6 +876,7 @@ our %Bits = ( 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [36] 'recursion' => "\x00\x00\x00\x00\x10\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", # [19] + 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [62] 'regexp' => "\x00\x00\x00\x00\x00\x01\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", # [37] 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [38] @@ -885,7 +897,7 @@ our %Bits = ( ); our %DeadBits = ( - 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x02", # [0..60] + 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..62] 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\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", # [30] 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] @@ -913,6 +925,7 @@ our %DeadBits = ( 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\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", # [12] + 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [61] 'newline' => "\x00\x00\x08\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", # [48] 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [49] @@ -929,6 +942,7 @@ our %DeadBits = ( 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [36] 'recursion' => "\x00\x00\x00\x00\x20\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", # [19] + 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [62] 'regexp' => "\x00\x00\x00\x00\x00\x02\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", # [37] 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [38] @@ -950,7 +964,7 @@ our %DeadBits = ( $NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; $DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x15\x01", # [2,56,52,53,57,54,58,55,60,4,22,23,25] -$LAST_BIT = 122 ; +$LAST_BIT = 126 ; $BYTES = 16 ; $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; diff --git a/locale.c b/locale.c index 64c0d8d..85c438c 100644 --- a/locale.c +++ b/locale.c @@ -93,7 +93,6 @@ void Perl_set_numeric_radix(pTHX) { #ifdef USE_LOCALE_NUMERIC - dVAR; # ifdef HAS_LOCALECONV const struct lconv* const lc = localeconv(); @@ -127,6 +126,20 @@ Perl_set_numeric_radix(pTHX) #endif /* USE_LOCALE_NUMERIC */ } +/* Is the C string input 'name' "C" or "POSIX"? If so, and 'name' is the + * return of setlocale(), then this is extremely likely to be the C or POSIX + * locale. However, the output of setlocale() is documented to be opaque, but + * the odds are extremely small that it would return these two strings for some + * other locale. Note that VMS in these two locales includes many non-ASCII + * characters as controls and punctuation (below are hex bytes): + * cntrl: 00-1F 7F 84-97 9B-9F + * punct: 21-2F 3A-40 5B-60 7B-7E A1-A3 A5 A7-AB B0-B3 B5-B7 B9-BD BF-CF D1-DD DF-EF F1-FD + * Oddly, none there are listed as alphas, though some represent alphabetics + * http://www.nntp.perl.org/group/perl.perl5.porters/2013/02/msg198753.html */ +#define isNAME_C_OR_POSIX(name) ((name) != NULL \ + && ((*(name) == 'C' && (*(name + 1)) == '\0') \ + || strEQ((name), "POSIX"))) + void Perl_new_numeric(pTHX_ const char *newnum) { @@ -164,7 +177,6 @@ Perl_new_numeric(pTHX_ const char *newnum) * POSIX::setlocale() */ char *save_newnum; - dVAR; if (! newnum) { Safefree(PL_numeric_name); @@ -180,8 +192,7 @@ Perl_new_numeric(pTHX_ const char *newnum) PL_numeric_name = save_newnum; } - PL_numeric_standard = ((*save_newnum == 'C' && save_newnum[1] == '\0') - || strEQ(save_newnum, "POSIX")); + PL_numeric_standard = isNAME_C_OR_POSIX(save_newnum); PL_numeric_local = TRUE; /* Keep LC_NUMERIC in the C locale. This is for XS modules, so they don't @@ -191,6 +202,8 @@ Perl_new_numeric(pTHX_ const char *newnum) set_numeric_radix(); +#else + PERL_UNUSED_ARG(newnum); #endif /* USE_LOCALE_NUMERIC */ } @@ -198,18 +211,16 @@ void Perl_set_numeric_standard(pTHX) { #ifdef USE_LOCALE_NUMERIC - dVAR; - - /* Toggle the LC_NUMERIC locale to C, if not already there. Probably - * should use the macros like SET_NUMERIC_STANDARD() in perl.h instead of - * calling this directly. */ - - if (_NOT_IN_NUMERIC_STANDARD) { - setlocale(LC_NUMERIC, "C"); - PL_numeric_standard = TRUE; - PL_numeric_local = FALSE; - set_numeric_radix(); - } + /* Toggle the LC_NUMERIC locale to C. Most code should use the macros like + * SET_NUMERIC_STANDARD() in perl.h instead of calling this directly. The + * macro avoids calling this routine if toggling isn't necessary according + * to our records (which could be wrong if some XS code has changed the + * locale behind our back) */ + + setlocale(LC_NUMERIC, "C"); + PL_numeric_standard = TRUE; + PL_numeric_local = isNAME_C_OR_POSIX(PL_numeric_name); + set_numeric_radix(); DEBUG_L(PerlIO_printf(Perl_debug_log, "Underlying LC_NUMERIC locale now is C\n")); @@ -220,18 +231,16 @@ void Perl_set_numeric_local(pTHX) { #ifdef USE_LOCALE_NUMERIC - dVAR; - - /* Toggle the LC_NUMERIC locale to the current underlying default, if not - * already there. Probably should use the macros like SET_NUMERIC_LOCAL() - * in perl.h instead of calling this directly. */ - - if (_NOT_IN_NUMERIC_LOCAL) { - setlocale(LC_NUMERIC, PL_numeric_name); - PL_numeric_standard = FALSE; - PL_numeric_local = TRUE; - set_numeric_radix(); - } + /* Toggle the LC_NUMERIC locale to the current underlying default. Most + * code should use the macros like SET_NUMERIC_LOCAL() in perl.h instead of + * calling this directly. The macro avoids calling this routine if + * toggling isn't necessary according to our records (which could be wrong + * if some XS code has changed the locale behind our back) */ + + setlocale(LC_NUMERIC, PL_numeric_name); + PL_numeric_standard = isNAME_C_OR_POSIX(PL_numeric_name); + PL_numeric_local = TRUE; + set_numeric_radix(); DEBUG_L(PerlIO_printf(Perl_debug_log, "Underlying LC_NUMERIC locale now is %s\n", PL_numeric_name)); @@ -300,8 +309,6 @@ Perl_new_collate(pTHX_ const char *newcoll) * should be called directly only from this file and from * POSIX::setlocale() */ - dVAR; - if (! newcoll) { if (PL_collation_name) { ++PL_collation_ix; @@ -318,8 +325,7 @@ Perl_new_collate(pTHX_ const char *newcoll) ++PL_collation_ix; Safefree(PL_collation_name); PL_collation_name = stdize_locale(savepv(newcoll)); - PL_collation_standard = ((*newcoll == 'C' && newcoll[1] == '\0') - || strEQ(newcoll, "POSIX")); + PL_collation_standard = isNAME_C_OR_POSIX(newcoll); { /* 2: at most so many chars ('a', 'b'). */ @@ -337,6 +343,8 @@ Perl_new_collate(pTHX_ const char *newcoll) } } +#else + PERL_UNUSED_ARG(newcoll); #endif /* USE_LOCALE_COLLATE */ } @@ -493,8 +501,6 @@ Perl_init_i18nl10n(pTHX_ int printwarn) int ok = 1; #if defined(USE_LOCALE) - dVAR; - #ifdef USE_LOCALE_CTYPE char *curctype = NULL; #endif /* USE_LOCALE_CTYPE */ @@ -926,6 +932,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) Safefree(curnum); #endif /* USE_LOCALE_NUMERIC */ +#else /* !USE_LOCALE */ + PERL_UNUSED_ARG(printwarn); #endif /* USE_LOCALE */ return ok; @@ -945,7 +953,6 @@ Perl_init_i18nl10n(pTHX_ int printwarn) char * Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen) { - dVAR; char *xbuf; STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */ @@ -1003,8 +1010,10 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) /* Returns TRUE if the current locale for 'category' is UTF-8; FALSE * otherwise. 'category' may not be LC_ALL. If the platform doesn't have * nl_langinfo(), nor MB_CUR_MAX, this employs a heuristic, which hence - * could give the wrong result. It errs on the side of not being a UTF-8 - * locale. */ + * could give the wrong result. The result will very likely be correct for + * languages that have commonly used non-ASCII characters, but for notably + * English, it comes down to if the locale's name ends in something like + * "UTF-8". It errs on the side of not being a UTF-8 locale. */ char *save_input_locale = NULL; STRLEN final_pos; @@ -1022,9 +1031,7 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) return FALSE; /* XXX maybe should croak */ } save_input_locale = stdize_locale(savepv(save_input_locale)); - if ((*save_input_locale == 'C' && save_input_locale[1] == '\0') - || strEQ(save_input_locale, "POSIX")) - { + if (isNAME_C_OR_POSIX(save_input_locale)) { DEBUG_L(PerlIO_printf(Perl_debug_log, "Current locale for category %d is %s\n", category, save_input_locale)); @@ -1043,12 +1050,13 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) if (category != LC_CTYPE) { /* These work only on LC_CTYPE */ /* Get the current LC_CTYPE locale */ - save_ctype_locale = stdize_locale(savepv(setlocale(LC_CTYPE, NULL))); + save_ctype_locale = setlocale(LC_CTYPE, NULL); if (! save_ctype_locale) { DEBUG_L(PerlIO_printf(Perl_debug_log, "Could not find current locale for LC_CTYPE\n")); goto cant_use_nllanginfo; } + save_ctype_locale = stdize_locale(savepv(save_ctype_locale)); /* If LC_CTYPE and the desired category use the same locale, this * means that finding the value for LC_CTYPE is the same as finding @@ -1076,8 +1084,9 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) # if defined(HAS_NL_LANGINFO) && defined(CODESET) { - char *codeset = savepv(nl_langinfo(CODESET)); + char *codeset = nl_langinfo(CODESET); if (codeset && strNE(codeset, "")) { + codeset = savepv(codeset); /* If we switched LC_CTYPE, switch back */ if (save_ctype_locale) { @@ -1095,7 +1104,6 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) Safefree(save_input_locale); return is_utf8; } - Safefree(codeset); } # endif @@ -1153,125 +1161,64 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) cant_use_nllanginfo: -#endif /* HAS_NL_LANGINFO etc */ +#else /* nl_langinfo should work if available, so don't bother compiling this + fallback code. The final fallback of looking at the name is + compiled, and will be executed if nl_langinfo fails */ - /* nl_langinfo not available or failed somehow. Look at the locale name to - * see if it matches qr/UTF -? 8 /ix */ - - final_pos = strlen(save_input_locale) - 1; - if (final_pos >= 3) { - char *name = save_input_locale; - - /* Find next 'U' or 'u' and look from there */ - while ((name += strcspn(name, "Uu") + 1) - <= save_input_locale + final_pos - 2) - { - if (toFOLD(*(name)) != 't' - || toFOLD(*(name + 1)) != 'f') - { - continue; - } - name += 2; - if (*(name) == '-') { - if ((name > save_input_locale + final_pos - 1)) { - break; - } - name++; - } - if (*(name) == '8') { - Safefree(save_input_locale); - DEBUG_L(PerlIO_printf(Perl_debug_log, - "Locale %s ends with UTF-8 in name\n", - save_input_locale)); - return TRUE; - } - } - DEBUG_L(PerlIO_printf(Perl_debug_log, - "Locale %s doesn't end with UTF-8 in name\n", - save_input_locale)); - } - -#ifdef WIN32 - /* http://msdn.microsoft.com/en-us/library/windows/desktop/dd317756.aspx */ - if (final_pos >= 4 - && *(save_input_locale + final_pos - 0) == '1' - && *(save_input_locale + final_pos - 1) == '0' - && *(save_input_locale + final_pos - 2) == '0' - && *(save_input_locale + final_pos - 3) == '5' - && *(save_input_locale + final_pos - 4) == '6') - { - DEBUG_L(PerlIO_printf(Perl_debug_log, - "Locale %s ends with 10056 in name, is UTF-8 locale\n", - save_input_locale)); - Safefree(save_input_locale); - return TRUE; - } -#endif - - /* Other common encodings are the ISO 8859 series, which aren't UTF-8 */ - if (instr(save_input_locale, "8859")) { - DEBUG_L(PerlIO_printf(Perl_debug_log, - "Locale %s has 8859 in name, not UTF-8 locale\n", - save_input_locale)); - Safefree(save_input_locale); - return FALSE; - } + /* nl_langinfo not available or failed somehow. Next try looking at the + * currency symbol to see if it disambiguates things. Often that will be + * in the native script, and if the symbol isn't in UTF-8, we know that the + * locale isn't. If it is non-ASCII UTF-8, we infer that the locale is + * too, as the odds of a non-UTF8 string being valid UTF-8 are quite small + * */ #ifdef HAS_LOCALECONV - # ifdef USE_LOCALE_MONETARY - - /* Here, there is nothing in the locale name to indicate whether the locale - * is UTF-8 or not. This "name", the return of setlocale(), is actually - * defined to be opaque, so we can't really rely on the absence of various - * substrings in the name to indicate its UTF-8ness. Look at the locale's - * currency symbol. Often that will be in the native script, and if the - * symbol isn't in UTF-8, we know that the locale isn't. If it is - * non-ASCII UTF-8, we infer that the locale is too. - * To do this, like above for LC_CTYPE, we first set LC_MONETARY to the - * locale of the desired category, if it isn't that locale already */ - { char *save_monetary_locale = NULL; - bool illegal_utf8 = FALSE; bool only_ascii = FALSE; - const struct lconv* const lc = localeconv(); + bool is_utf8 = FALSE; + struct lconv* lc; + + /* Like above for LC_CTYPE, we first set LC_MONETARY to the locale of + * the desired category, if it isn't that locale already */ if (category != LC_MONETARY) { - save_monetary_locale = stdize_locale(savepv(setlocale(LC_MONETARY, - NULL))); + save_monetary_locale = setlocale(LC_MONETARY, NULL); if (! save_monetary_locale) { DEBUG_L(PerlIO_printf(Perl_debug_log, "Could not find current locale for LC_MONETARY\n")); goto cant_use_monetary; } + save_monetary_locale = stdize_locale(savepv(save_monetary_locale)); - if (strNE(save_monetary_locale, save_input_locale)) { - if (! setlocale(LC_MONETARY, save_input_locale)) { - DEBUG_L(PerlIO_printf(Perl_debug_log, - "Could not change LC_MONETARY locale to %s\n", - save_input_locale)); - Safefree(save_monetary_locale); - goto cant_use_monetary; - } + if (strEQ(save_monetary_locale, save_input_locale)) { + Safefree(save_monetary_locale); + save_monetary_locale = NULL; + } + else if (! setlocale(LC_MONETARY, save_input_locale)) { + DEBUG_L(PerlIO_printf(Perl_debug_log, + "Could not change LC_MONETARY locale to %s\n", + save_input_locale)); + Safefree(save_monetary_locale); + goto cant_use_monetary; } } /* Here the current LC_MONETARY is set to the locale of the category * whose information is desired. */ - if (lc && lc->currency_symbol) { - if (! is_utf8_string((U8 *) lc->currency_symbol, 0)) { - DEBUG_L(PerlIO_printf(Perl_debug_log, - "Currency symbol for %s is not legal UTF-8\n", - save_input_locale)); - illegal_utf8 = TRUE; - } - else if (is_ascii_string((U8 *) lc->currency_symbol, 0)) { - DEBUG_L(PerlIO_printf(Perl_debug_log, "Currency symbol for %s contains only ASCII; can't use for determining if UTF-8 locale\n", save_input_locale)); - only_ascii = TRUE; - } + lc = localeconv(); + if (! lc + || ! lc->currency_symbol + || is_ascii_string((U8 *) lc->currency_symbol, 0)) + { + DEBUG_L(PerlIO_printf(Perl_debug_log, "Couldn't get currency symbol for %s, or contains only ASCII; can't use for determining if UTF-8 locale\n", save_input_locale)); + only_ascii = TRUE; + } + else { + is_utf8 = is_utf8_string((U8 *) lc->currency_symbol, 0); } /* If we changed it, restore LC_MONETARY to its original locale */ @@ -1280,86 +1227,179 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) Safefree(save_monetary_locale); } - Safefree(save_input_locale); - - /* It isn't a UTF-8 locale if the symbol is not legal UTF-8; otherwise - * assume the locale is UTF-8 if and only if the symbol is non-ascii - * UTF-8. (We can't really tell if the locale is UTF-8 or not if the - * symbol is just a '$', so we err on the side of it not being UTF-8) - * */ - DEBUG_L(PerlIO_printf(Perl_debug_log, "\tis_utf8=%d\n", (illegal_utf8) - ? FALSE - : ! only_ascii)); - return (illegal_utf8) - ? FALSE - : ! only_ascii; + if (! only_ascii) { + /* It isn't a UTF-8 locale if the symbol is not legal UTF-8; + * otherwise assume the locale is UTF-8 if and only if the symbol + * is non-ascii UTF-8. */ + DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?Currency symbol for %s is UTF-8=%d\n", + save_input_locale, is_utf8)); + Safefree(save_input_locale); + return is_utf8; + } } cant_use_monetary: # endif /* USE_LOCALE_MONETARY */ #endif /* HAS_LOCALECONV */ -#if 0 && defined(HAS_STRERROR) && defined(USE_LOCALE_MESSAGES) +#if defined(HAS_STRFTIME) && defined(USE_LOCALE_TIME) + +/* Still haven't found a non-ASCII string to disambiguate UTF-8 or not. Try + * the names of the months and weekdays, timezone, and am/pm indicator */ + { + char *save_time_locale = NULL; + int hour = 10; + bool is_dst = FALSE; + int dom = 1; + int month = 0; + int i; + char * formatted_time; + + + /* Like above for LC_MONETARY, we set LC_TIME to the locale of the + * desired category, if it isn't that locale already */ + + if (category != LC_TIME) { + + save_time_locale = setlocale(LC_TIME, NULL); + if (! save_time_locale) { + DEBUG_L(PerlIO_printf(Perl_debug_log, + "Could not find current locale for LC_TIME\n")); + goto cant_use_time; + } + save_time_locale = stdize_locale(savepv(save_time_locale)); + + if (strEQ(save_time_locale, save_input_locale)) { + Safefree(save_time_locale); + save_time_locale = NULL; + } + else if (! setlocale(LC_TIME, save_input_locale)) { + DEBUG_L(PerlIO_printf(Perl_debug_log, + "Could not change LC_TIME locale to %s\n", + save_input_locale)); + Safefree(save_time_locale); + goto cant_use_time; + } + } + + /* Here the current LC_TIME is set to the locale of the category + * whose information is desired. Look at all the days of the week and + * month names, and the timezone and am/pm indicator for non-ASCII + * characters. The first such a one found will tell us if the locale + * is UTF-8 or not */ + + for (i = 0; i < 7 + 12; i++) { /* 7 days; 12 months */ + formatted_time = my_strftime("%A %B %Z %p", + 0, 0, hour, dom, month, 112, 0, 0, is_dst); + if (! formatted_time || is_ascii_string((U8 *) formatted_time, 0)) { + + /* Here, we didn't find a non-ASCII. Try the next time through + * with the complemented dst and am/pm, and try with the next + * weekday. After we have gotten all weekdays, try the next + * month */ + is_dst = ! is_dst; + hour = (hour + 12) % 24; + dom++; + if (i > 6) { + month++; + } + continue; + } + + /* Here, we have a non-ASCII. Return TRUE is it is valid UTF8; + * false otherwise. But first, restore LC_TIME to its original + * locale if we changed it */ + if (save_time_locale) { + setlocale(LC_TIME, save_time_locale); + Safefree(save_time_locale); + } + + DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?time-related strings for %s are UTF-8=%d\n", + save_input_locale, + is_utf8_string((U8 *) formatted_time, 0))); + Safefree(save_input_locale); + return is_utf8_string((U8 *) formatted_time, 0); + } + + /* Falling off the end of the loop indicates all the names were just + * ASCII. Go on to the next test. If we changed it, restore LC_TIME + * to its original locale */ + if (save_time_locale) { + setlocale(LC_TIME, save_time_locale); + Safefree(save_time_locale); + } + DEBUG_L(PerlIO_printf(Perl_debug_log, "All time-related words for %s contain only ASCII; can't use for determining if UTF-8 locale\n", save_input_locale)); + } + cant_use_time: + +#endif + +#if 0 && defined(USE_LOCALE_MESSAGES) && defined(HAS_SYS_ERRLIST) /* This code is ifdefd out because it was found to not be necessary in testing - * on our dromedary test machine, which has over 700 locales. There, looking - * at just the currency symbol gave essentially the same results as doing this - * extra work. Executing this also caused segfaults in miniperl. I left it in - * so as to avoid rewriting it if real-world experience indicates that - * dromedary is an outlier. Essentially, instead of returning abpve if we + * on our dromedary test machine, which has over 700 locales. There, this + * added no value to looking at the currency symbol and the time strings. I + * left it in so as to avoid rewriting it if real-world experience indicates + * that dromedary is an outlier. Essentially, instead of returning abpve if we * haven't found illegal utf8, we continue on and examine all the strerror() * messages on the platform for utf8ness. If all are ASCII, we still don't * know the answer; but otherwise we have a pretty good indication of the - * utf8ness. The reason this doesn't necessarily help much is that the - * messages may not have been translated into the locale. The currency symbol - * is much more likely to have been translated. The code below would need to - * be altered somewhat to just be a continuation of testing the currency - * symbol. */ + * utf8ness. The reason this doesn't help much is that the messages may not + * have been translated into the locale. The currency symbol and time strings + * are much more likely to have been translated. */ + { int e; - unsigned int failures = 0, non_ascii = 0; + bool is_utf8 = FALSE; + bool non_ascii = FALSE; char *save_messages_locale = NULL; + const char * errmsg = NULL; - /* Like above for LC_CTYPE, we set LC_MESSAGES to the locale of the - * desired category, if it isn't that locale already */ + /* Like above, we set LC_MESSAGES to the locale of the desired + * category, if it isn't that locale already */ if (category != LC_MESSAGES) { - save_messages_locale = stdize_locale(savepv(setlocale(LC_MESSAGES, - NULL))); + save_messages_locale = setlocale(LC_MESSAGES, NULL); if (! save_messages_locale) { + DEBUG_L(PerlIO_printf(Perl_debug_log, + "Could not find current locale for LC_MESSAGES\n")); goto cant_use_messages; } + save_messages_locale = stdize_locale(savepv(save_messages_locale)); if (strEQ(save_messages_locale, save_input_locale)) { - Safefree(save_input_locale); + Safefree(save_messages_locale); + save_messages_locale = NULL; } else if (! setlocale(LC_MESSAGES, save_input_locale)) { + DEBUG_L(PerlIO_printf(Perl_debug_log, + "Could not change LC_MESSAGES locale to %s\n", + save_input_locale)); Safefree(save_messages_locale); goto cant_use_messages; } } /* Here the current LC_MESSAGES is set to the locale of the category - * whose information is desired. Look through all the messages */ + * whose information is desired. Look through all the messages. We + * can't use Strerror() here because it may expand to code that + * segfaults in miniperl */ - for (e = 0; -#ifdef HAS_SYS_ERRLIST - e <= sys_nerr -#endif - ; e++) - { - const U8* const errmsg = (U8 *) Strerror(e) ; - if (!errmsg) - break; - if (! is_utf8_string(errmsg, 0)) { - failures++; + for (e = 0; e <= sys_nerr; e++) { + errno = 0; + errmsg = sys_errlist[e]; + if (errno || !errmsg) { break; } - else if (! is_ascii_string(errmsg, 0)) { - non_ascii++; + errmsg = savepv(errmsg); + if (! is_ascii_string((U8 *) errmsg, 0)) { + non_ascii = TRUE; + is_utf8 = is_utf8_string((U8 *) errmsg, 0); + break; } } + Safefree(errmsg); /* And, if we changed it, restore LC_MESSAGES to its original locale */ if (save_messages_locale) { @@ -1367,15 +1407,95 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) Safefree(save_messages_locale); } - /* Any non-UTF-8 message means not a UTF-8 locale; if all are valid, - * any non-ascii means it is one; otherwise we assume it isn't */ - return (failures) ? FALSE : non_ascii; + if (non_ascii) { + + /* Any non-UTF-8 message means not a UTF-8 locale; if all are valid, + * any non-ascii means it is one; otherwise we assume it isn't */ + DEBUG_L(PerlIO_printf(Perl_debug_log, "\t?error messages for %s are UTF-8=%d\n", + save_input_locale, + is_utf8)); + Safefree(save_input_locale); + return is_utf8; + } + DEBUG_L(PerlIO_printf(Perl_debug_log, "All error messages for %s contain only ASCII; can't use for determining if UTF-8 locale\n", save_input_locale)); } cant_use_messages: #endif +#endif /* the code that is compiled when no nl_langinfo */ + + /* As a last resort, look at the locale name to see if it matches + * qr/UTF -? * 8 /ix, or some other common locale names. This "name", the + * return of setlocale(), is actually defined to be opaque, so we can't + * really rely on the absence of various substrings in the name to indicate + * its UTF-8ness, but if it has UTF8 in the name, it is extremely likely to + * be a UTF-8 locale. Similarly for the other common names */ + + final_pos = strlen(save_input_locale) - 1; + if (final_pos >= 3) { + char *name = save_input_locale; + + /* Find next 'U' or 'u' and look from there */ + while ((name += strcspn(name, "Uu") + 1) + <= save_input_locale + final_pos - 2) + { + if (toFOLD(*(name)) != 't' + || toFOLD(*(name + 1)) != 'f') + { + continue; + } + name += 2; + if (*(name) == '-') { + if ((name > save_input_locale + final_pos - 1)) { + break; + } + name++; + } + if (*(name) == '8') { + DEBUG_L(PerlIO_printf(Perl_debug_log, + "Locale %s ends with UTF-8 in name\n", + save_input_locale)); + Safefree(save_input_locale); + return TRUE; + } + } + DEBUG_L(PerlIO_printf(Perl_debug_log, + "Locale %s doesn't end with UTF-8 in name\n", + save_input_locale)); + } + +#ifdef WIN32 + /* http://msdn.microsoft.com/en-us/library/windows/desktop/dd317756.aspx */ + if (final_pos >= 4 + && *(save_input_locale + final_pos - 0) == '1' + && *(save_input_locale + final_pos - 1) == '0' + && *(save_input_locale + final_pos - 2) == '0' + && *(save_input_locale + final_pos - 3) == '5' + && *(save_input_locale + final_pos - 4) == '6') + { + DEBUG_L(PerlIO_printf(Perl_debug_log, + "Locale %s ends with 10056 in name, is UTF-8 locale\n", + save_input_locale)); + Safefree(save_input_locale); + return TRUE; + } +#endif + + /* Other common encodings are the ISO 8859 series, which aren't UTF-8. But + * since we are about to return FALSE anyway, there is no point in doing + * this extra work */ +#if 0 + if (instr(save_input_locale, "8859")) { + DEBUG_L(PerlIO_printf(Perl_debug_log, + "Locale %s has 8859 in name, not UTF-8 locale\n", + save_input_locale)); + Safefree(save_input_locale); + return FALSE; + } +#endif + DEBUG_L(PerlIO_printf(Perl_debug_log, "Assuming locale %s is not a UTF-8 locale\n", save_input_locale)); @@ -1416,9 +1536,7 @@ Perl_my_strerror(pTHX_ const int errnum) { #ifdef USE_LOCALE_MESSAGES if (! IN_LC(LC_MESSAGES)) { char * save_locale = setlocale(LC_MESSAGES, NULL); - if (! ((*save_locale == 'C' && save_locale[1] == '\0') - || strEQ(save_locale, "POSIX"))) - { + if (! isNAME_C_OR_POSIX(save_locale)) { char *errstr; /* The next setlocale likely will zap this, so create a copy */ diff --git a/make_ext.pl b/make_ext.pl index f10a47c..a67e894 100644 --- a/make_ext.pl +++ b/make_ext.pl @@ -51,13 +51,15 @@ my $ext_dirs_re = '(?:' . join('|', @ext_dirs) . ')'; # It may be deleted in a later release of perl so try to # avoid using it for other purposes. -my (%excl, %incl, %opts, @extspec, @pass_through); +my (%excl, %incl, %opts, @extspec, @pass_through, $verbose); foreach (@ARGV) { if (/^!(.*)$/) { $excl{$1} = 1; } elsif (/^\+(.*)$/) { $incl{$1} = 1; + } elsif (/^--verbose$/ or /^-v$/) { + $verbose = 1; } elsif (/^--([\w\-]+)$/) { $opts{$1} = 1; } elsif (/^--([\w\-]+)=(.*)$/) { @@ -153,11 +155,11 @@ if ($is_Win32) { my $pl2bat = "$topdir\\win32\\bin\\pl2bat"; unless (-f "$pl2bat.bat") { my @args = ($perl, "-I$topdir\\lib", ("$pl2bat.pl") x 2); - print "@args\n"; + print "@args\n" if $verbose; system(@args) unless IS_CROSS; } - print "In $build"; + print "In $build" if $verbose; foreach my $dir (@dirs) { chdir($dir) or die "Cannot cd to $dir: $!\n"; (my $ext = Cwd::getcwd()) =~ s{/}{\\}g; @@ -252,7 +254,7 @@ foreach my $spec (@extspec) { } } - print "\tMaking $mname ($target)\n"; + print "\tMaking $mname ($target)\n" if $verbose; build_extension($ext_pathname, $perl, $mname, $target, [@pass_through, @{$extra_passthrough{$spec} || []}]); @@ -348,7 +350,7 @@ sub build_extension { return; } - print "\nCreating Makefile.PL in $ext_dir for $mname\n"; + print "\nCreating Makefile.PL in $ext_dir for $mname\n" if $verbose; my ($fromname, $key, $value); if ($mname eq 'podlators') { # We need to special case this somewhere, and this is fewer @@ -491,7 +493,7 @@ EOM } # We are going to have to use Makefile.PL: - print "\nRunning Makefile.PL in $ext_dir\n"; + print "\nRunning Makefile.PL in $ext_dir\n" if $verbose; my @args = ("-I$lib_dir", 'Makefile.PL'); if ($is_VMS) { @@ -503,7 +505,7 @@ EOM } push @args, @$pass_through; _quote_args(\@args) if $is_VMS; - print join(' ', $perl, @args), "\n"; + print join(' ', $perl, @args), "\n" if $verbose; my $code = system $perl, @args; warn "$code from $ext_dir\'s Makefile.PL" if $code; @@ -529,7 +531,7 @@ else if test ! -f Makefile ; then echo "Warning: No Makefile!" fi - make $clean_target MAKE='@make' @pass_through + @make $clean_target MAKE='@make' @pass_through fi cd $return_dir EOS @@ -556,7 +558,7 @@ EOS system(@make, @args) and print "@make @args failed, continuing anyway...\n"; } my @targ = ($target, @$pass_through); - print "Making $target in $ext_dir\n@make @targ\n"; + print "Making $target in $ext_dir\n@make @targ\n" if $verbose; local $ENV{PERL_INSTALL_QUIET} = 1; my $code = system(@make, @targ); die "Unsuccessful make($ext_dir): code=$code" if $code != 0; diff --git a/mathoms.c b/mathoms.c index b284a38..f9b9462 100644 --- a/mathoms.c +++ b/mathoms.c @@ -551,7 +551,6 @@ Perl_sv_utf8_upgrade(pTHX_ SV *sv) int Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...) { - dTHXs; int ret = 0; va_list(arglist); @@ -775,8 +774,6 @@ Perl_sv_nounlocking(pTHX_ SV *sv) void Perl_save_long(pTHX_ long int *longp) { - dVAR; - PERL_ARGS_ASSERT_SAVE_LONG; SSCHECK(3); @@ -788,8 +785,6 @@ Perl_save_long(pTHX_ long int *longp) void Perl_save_iv(pTHX_ IV *ivp) { - dVAR; - PERL_ARGS_ASSERT_SAVE_IV; SSCHECK(3); @@ -801,8 +796,6 @@ Perl_save_iv(pTHX_ IV *ivp) void Perl_save_nogv(pTHX_ GV *gv) { - dVAR; - PERL_ARGS_ASSERT_SAVE_NOGV; SSCHECK(2); @@ -813,7 +806,6 @@ Perl_save_nogv(pTHX_ GV *gv) void Perl_save_list(pTHX_ SV **sarg, I32 maxsarg) { - dVAR; I32 i; PERL_ARGS_ASSERT_SAVE_LIST; @@ -1056,15 +1048,12 @@ Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, void Perl_save_freesv(pTHX_ SV *sv) { - dVAR; save_freesv(sv); } void Perl_save_mortalizesv(pTHX_ SV *sv) { - dVAR; - PERL_ARGS_ASSERT_SAVE_MORTALIZESV; save_mortalizesv(sv); @@ -1073,21 +1062,18 @@ Perl_save_mortalizesv(pTHX_ SV *sv) void Perl_save_freeop(pTHX_ OP *o) { - dVAR; save_freeop(o); } void Perl_save_freepv(pTHX_ char *pv) { - dVAR; save_freepv(pv); } void Perl_save_op(pTHX) { - dVAR; save_op(); } @@ -1421,8 +1407,6 @@ Perl_is_uni_idfirst(pTHX_ UV c) bool Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */ { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_IDFIRST; return _is_utf8_idstart(p); @@ -1431,8 +1415,6 @@ Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */ bool Perl_is_utf8_xidfirst(pTHX_ const U8 *p) /* The naming is historical. */ { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_XIDFIRST; return _is_utf8_xidstart(p); @@ -1441,8 +1423,6 @@ Perl_is_utf8_xidfirst(pTHX_ const U8 *p) /* The naming is historical. */ bool Perl_is_utf8_idcont(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_IDCONT; return _is_utf8_idcont(p); @@ -1451,8 +1431,6 @@ Perl_is_utf8_idcont(pTHX_ const U8 *p) bool Perl_is_utf8_xidcont(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_XIDCONT; return _is_utf8_xidcont(p); @@ -1533,8 +1511,6 @@ Perl_to_uni_lower_lc(pTHX_ U32 c) bool Perl_is_utf8_alnum(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_ALNUM; /* NOTE: "IsWord", not "IsAlnum", since Alnum is a true @@ -1546,8 +1522,6 @@ Perl_is_utf8_alnum(pTHX_ const U8 *p) bool Perl_is_utf8_alnumc(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_ALNUMC; return isALPHANUMERIC_utf8(p); @@ -1556,8 +1530,6 @@ Perl_is_utf8_alnumc(pTHX_ const U8 *p) bool Perl_is_utf8_alpha(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_ALPHA; return isALPHA_utf8(p); @@ -1566,8 +1538,6 @@ Perl_is_utf8_alpha(pTHX_ const U8 *p) bool Perl_is_utf8_ascii(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_ASCII; PERL_UNUSED_CONTEXT; @@ -1577,8 +1547,6 @@ Perl_is_utf8_ascii(pTHX_ const U8 *p) bool Perl_is_utf8_blank(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_BLANK; PERL_UNUSED_CONTEXT; @@ -1588,8 +1556,6 @@ Perl_is_utf8_blank(pTHX_ const U8 *p) bool Perl_is_utf8_space(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_SPACE; PERL_UNUSED_CONTEXT; @@ -1599,8 +1565,6 @@ Perl_is_utf8_space(pTHX_ const U8 *p) bool Perl_is_utf8_perl_space(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE; PERL_UNUSED_CONTEXT; @@ -1612,8 +1576,6 @@ Perl_is_utf8_perl_space(pTHX_ const U8 *p) bool Perl_is_utf8_perl_word(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD; PERL_UNUSED_CONTEXT; @@ -1625,8 +1587,6 @@ Perl_is_utf8_perl_word(pTHX_ const U8 *p) bool Perl_is_utf8_digit(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_DIGIT; return isDIGIT_utf8(p); @@ -1635,8 +1595,6 @@ Perl_is_utf8_digit(pTHX_ const U8 *p) bool Perl_is_utf8_posix_digit(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT; PERL_UNUSED_CONTEXT; @@ -1648,8 +1606,6 @@ Perl_is_utf8_posix_digit(pTHX_ const U8 *p) bool Perl_is_utf8_upper(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_UPPER; return isUPPER_utf8(p); @@ -1658,8 +1614,6 @@ Perl_is_utf8_upper(pTHX_ const U8 *p) bool Perl_is_utf8_lower(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_LOWER; return isLOWER_utf8(p); @@ -1668,8 +1622,6 @@ Perl_is_utf8_lower(pTHX_ const U8 *p) bool Perl_is_utf8_cntrl(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_CNTRL; PERL_UNUSED_CONTEXT; @@ -1679,8 +1631,6 @@ Perl_is_utf8_cntrl(pTHX_ const U8 *p) bool Perl_is_utf8_graph(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_GRAPH; return isGRAPH_utf8(p); @@ -1689,8 +1639,6 @@ Perl_is_utf8_graph(pTHX_ const U8 *p) bool Perl_is_utf8_print(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_PRINT; return isPRINT_utf8(p); @@ -1699,8 +1647,6 @@ Perl_is_utf8_print(pTHX_ const U8 *p) bool Perl_is_utf8_punct(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_PUNCT; return isPUNCT_utf8(p); @@ -1709,8 +1655,6 @@ Perl_is_utf8_punct(pTHX_ const U8 *p) bool Perl_is_utf8_xdigit(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_XDIGIT; PERL_UNUSED_CONTEXT; @@ -1720,8 +1664,6 @@ Perl_is_utf8_xdigit(pTHX_ const U8 *p) bool Perl_is_utf8_mark(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_MARK; return _is_utf8_mark(p); diff --git a/mg.c b/mg.c index 3a0f18b..28ed156 100644 --- a/mg.c +++ b/mg.c @@ -93,7 +93,6 @@ struct magic_state { STATIC void S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags) { - dVAR; MGS* mgs; bool bumped = FALSE; @@ -136,11 +135,10 @@ Turns on the magical status of an SV. See C. */ void -Perl_mg_magical(pTHX_ SV *sv) +Perl_mg_magical(SV *sv) { const MAGIC* mg; PERL_ARGS_ASSERT_MG_MAGICAL; - PERL_UNUSED_CONTEXT; SvMAGICAL_off(sv); if ((mg = SvMAGIC(sv))) { @@ -172,7 +170,6 @@ be >= SVt_PVMG. See C. int Perl_mg_get(pTHX_ SV *sv) { - dVAR; const I32 mgs_ix = SSNEW(sizeof(MGS)); bool saved = FALSE; bool have_new = 0; @@ -255,7 +252,6 @@ Do magic after a value is assigned to the SV. See C. int Perl_mg_set(pTHX_ SV *sv) { - dVAR; const I32 mgs_ix = SSNEW(sizeof(MGS)); MAGIC* mg; MAGIC* nextmg; @@ -299,7 +295,6 @@ higher. Use sv_len() instead. U32 Perl_mg_length(pTHX_ SV *sv) { - dVAR; MAGIC* mg; STRLEN len; @@ -387,10 +382,8 @@ Perl_mg_clear(pTHX_ SV *sv) } static MAGIC* -S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags) +S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags) { - PERL_UNUSED_CONTEXT; - assert(flags <= 1); if (sv) { @@ -417,9 +410,9 @@ Finds the magic pointer for type matching the SV. See C. */ MAGIC* -Perl_mg_find(pTHX_ const SV *sv, int type) +Perl_mg_find(const SV *sv, int type) { - return S_mg_findext_flags(aTHX_ sv, type, NULL, 0); + return S_mg_findext_flags(sv, type, NULL, 0); } /* @@ -432,9 +425,9 @@ C. */ MAGIC* -Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl) +Perl_mg_findext(const SV *sv, int type, const MGVTBL *vtbl) { - return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1); + return S_mg_findext_flags(sv, type, vtbl, 1); } MAGIC * @@ -448,7 +441,7 @@ Perl_mg_find_mglob(pTHX_ SV *sv) sv = LvTARG(sv); } if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) - return S_mg_findext_flags(aTHX_ sv, PERL_MAGIC_regex_global, 0, 0); + return S_mg_findext_flags(sv, PERL_MAGIC_regex_global, 0, 0); return NULL; } @@ -508,7 +501,6 @@ and that will handle the magic. void Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic) { - dVAR; MAGIC *mg; PERL_ARGS_ASSERT_MG_LOCALIZE; @@ -623,7 +615,6 @@ Perl_mg_free_type(pTHX_ SV *sv, int how) U32 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) { - dVAR; PERL_UNUSED_ARG(sv); PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT; @@ -655,8 +646,6 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) { - dVAR; - PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET; if (PL_curpm) { @@ -785,7 +774,6 @@ S_fixup_errno_string(pTHX_ SV* sv) int Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { - dVAR; I32 paren; const char *s = NULL; REGEXP *rx; @@ -1150,7 +1138,6 @@ Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) { - dVAR; STRLEN len = 0, klen; const char * const key = MgPV_const(mg,klen); const char *s = ""; @@ -1259,7 +1246,6 @@ Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) { - dVAR; PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV; PERL_UNUSED_ARG(mg); #if defined(VMS) @@ -1282,7 +1268,6 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) { - dVAR; PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV; PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg); @@ -1306,7 +1291,6 @@ restore_sigmask(pTHX_ SV *save_sv) int Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) { - dVAR; /* Are we fetching a signal entry? */ int i = (I16)mg->mg_private; @@ -1448,7 +1432,6 @@ unblock_sigmask(pTHX_ void* newset) void Perl_despatch_signals(pTHX) { - dVAR; int sig; PL_sig_pending = 0; for (sig = 1; sig < SIG_SIZE; sig++) { @@ -1650,7 +1633,6 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) { - dVAR; PERL_ARGS_ASSERT_MAGIC_SETISA; PERL_UNUSED_ARG(sv); @@ -1665,9 +1647,7 @@ Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg) { - dVAR; HV* stash; - PERL_ARGS_ASSERT_MAGIC_CLEARISA; /* Bail out if destruction is going on */ @@ -1769,7 +1749,6 @@ SV* Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, U32 argc, ...) { - dVAR; dSP; SV* ret = NULL; @@ -1826,7 +1805,6 @@ STATIC SV* S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, int n, SV *val) { - dVAR; SV* arg1 = NULL; PERL_ARGS_ASSERT_MAGIC_METHCALL1; @@ -1851,7 +1829,6 @@ S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, STATIC int S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth) { - dVAR; SV* ret; PERL_ARGS_ASSERT_MAGIC_METHPACK; @@ -1876,7 +1853,6 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; MAGIC *tmg; SV *val; @@ -1918,7 +1894,6 @@ Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) U32 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; I32 retval = 0; SV* retsv; @@ -1936,8 +1911,6 @@ Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; - PERL_ARGS_ASSERT_MAGIC_WIPEPACK; Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0); @@ -1947,7 +1920,6 @@ Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) { - dVAR; SV* ret; PERL_ARGS_ASSERT_MAGIC_NEXTPACK; @@ -1970,7 +1942,6 @@ Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg) SV * Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) { - dVAR; SV *retval; SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg); HV * const pkg = SvSTASH((const SV *)SvRV(tied)); @@ -1999,7 +1970,6 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) int Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) { - dVAR; SV **svp; PERL_ARGS_ASSERT_MAGIC_SETDBLINE; @@ -2037,7 +2007,6 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) { - dVAR; AV * const obj = MUTABLE_AV(mg->mg_obj); PERL_ARGS_ASSERT_MAGIC_GETARYLEN; @@ -2053,7 +2022,6 @@ Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) int Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) { - dVAR; AV * const obj = MUTABLE_AV(mg->mg_obj); PERL_ARGS_ASSERT_MAGIC_SETARYLEN; @@ -2070,8 +2038,6 @@ Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg) { - dVAR; - PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P; PERL_UNUSED_ARG(sv); PERL_UNUSED_CONTEXT; @@ -2090,8 +2056,6 @@ Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) { - dVAR; - PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P; PERL_UNUSED_ARG(sv); @@ -2115,7 +2079,6 @@ Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) { - dVAR; SV* const lsv = LvTARG(sv); MAGIC * const found = mg_find_mglob(lsv); @@ -2136,7 +2099,6 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) { - dVAR; SV* const lsv = LvTARG(sv); SSize_t pos; STRLEN len; @@ -2216,7 +2178,6 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) { - dVAR; STRLEN len, lsv_len, oldtarglen, newtarglen; const char * const tmps = SvPV_const(sv, len); SV * const lsv = LvTARG(sv); @@ -2270,8 +2231,6 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) { - dVAR; - PERL_ARGS_ASSERT_MAGIC_GETTAINT; PERL_UNUSED_ARG(sv); #ifdef NO_TAINT_SUPPORT @@ -2285,8 +2244,6 @@ Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) { - dVAR; - PERL_ARGS_ASSERT_MAGIC_SETTAINT; PERL_UNUSED_ARG(sv); @@ -2323,7 +2280,6 @@ Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg) SV * Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg) { - dVAR; SV *targ = NULL; PERL_ARGS_ASSERT_DEFELEM_TARGET; if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem); @@ -2388,7 +2344,6 @@ Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg) void Perl_vivify_defelem(pTHX_ SV *sv) { - dVAR; MAGIC *mg; SV *value = NULL; @@ -2509,7 +2464,9 @@ Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) { +#ifdef USE_ITHREADS dVAR; +#endif const char *s; I32 paren; const REGEXP * rx; @@ -3086,7 +3043,6 @@ Perl_whichsig_sv(pTHX_ SV *sigsv) const char *sigpv; STRLEN siglen; PERL_ARGS_ASSERT_WHICHSIG_SV; - PERL_UNUSED_CONTEXT; sigpv = SvPV_const(sigsv, siglen); return whichsig_pvn(sigpv, siglen); } @@ -3095,7 +3051,6 @@ I32 Perl_whichsig_pv(pTHX_ const char *sig) { PERL_ARGS_ASSERT_WHICHSIG_PV; - PERL_UNUSED_CONTEXT; return whichsig_pvn(sig, strlen(sig)); } @@ -3275,7 +3230,6 @@ cleanup: static void S_restore_magic(pTHX_ const void *p) { - dVAR; MGS* const mgs = SSPTR(PTR2IV(p), MGS*); SV* const sv = mgs->mgs_sv; bool bumped; @@ -3341,7 +3295,6 @@ S_restore_magic(pTHX_ const void *p) static void S_unwind_handler_stack(pTHX_ const void *p) { - dVAR; PERL_UNUSED_ARG(p); PL_savestack_ix -= 5; /* Unprotect save in progress. */ @@ -3360,7 +3313,6 @@ reference. int Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) { - dVAR; SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr) : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); @@ -3391,8 +3343,6 @@ C. int Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) { - dVAR; - PERL_ARGS_ASSERT_MAGIC_CLEARHINT; PERL_UNUSED_ARG(sv); diff --git a/mro.c b/mro.c index 2440397..c9b40e5 100644 --- a/mro.c +++ b/mro.c @@ -492,7 +492,6 @@ by the C magic, should not need to invoke directly. void Perl_mro_isa_changed_in(pTHX_ HV* stash) { - dVAR; HV* isarev; AV* linear_mro; HE* iter; @@ -1402,7 +1401,6 @@ XS(XS_mro_method_changed_in); void Perl_boot_core_mro(pTHX) { - dVAR; static const char file[] = __FILE__; Perl_mro_register(aTHX_ &dfs_alg); @@ -1412,7 +1410,6 @@ Perl_boot_core_mro(pTHX) XS(XS_mro_method_changed_in) { - dVAR; dXSARGS; SV* classname; HV* class_stash; diff --git a/numeric.c b/numeric.c index e0ffafa..4876ece 100644 --- a/numeric.c +++ b/numeric.c @@ -30,9 +30,8 @@ values, including such things as replacements for the OS's atof() function #include "perl.h" U32 -Perl_cast_ulong(pTHX_ NV f) +Perl_cast_ulong(NV f) { - PERL_UNUSED_CONTEXT; if (f < 0.0) return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f; if (f < U32_MAX_P1) { @@ -49,9 +48,8 @@ Perl_cast_ulong(pTHX_ NV f) } I32 -Perl_cast_i32(pTHX_ NV f) +Perl_cast_i32(NV f) { - PERL_UNUSED_CONTEXT; if (f < I32_MAX_P1) return f < I32_MIN ? I32_MIN : (I32) f; if (f < U32_MAX_P1) { @@ -68,9 +66,8 @@ Perl_cast_i32(pTHX_ NV f) } IV -Perl_cast_iv(pTHX_ NV f) +Perl_cast_iv(NV f) { - PERL_UNUSED_CONTEXT; if (f < IV_MAX_P1) return f < IV_MIN ? IV_MIN : (IV) f; if (f < UV_MAX_P1) { @@ -88,9 +85,8 @@ Perl_cast_iv(pTHX_ NV f) } UV -Perl_cast_uv(pTHX_ NV f) +Perl_cast_uv(NV f) { - PERL_UNUSED_CONTEXT; if (f < 0.0) return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f; if (f < UV_MAX_P1) { @@ -263,7 +259,6 @@ on this platform. UV Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { - dVAR; const char *s = start; STRLEN len = *len_p; UV value = 0; @@ -524,8 +519,6 @@ bool Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC - dVAR; - PERL_ARGS_ASSERT_GROK_NUMERIC_RADIX; if (IN_LC(LC_NUMERIC)) { @@ -555,7 +548,7 @@ Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) } /* -=for apidoc grok_number +=for apidoc grok_number_flags Recognise (or not) a number. The type of the number is returned (0 if unrecognised), otherwise it is a bit-ORed combination of @@ -575,11 +568,27 @@ IS_NUMBER_NEG if the number is negative (in which case *valuep holds the absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the number is larger than a UV. +C allows only C, which allows for trailing +non-numeric text on an otherwise successful I, setting +C on the result. + +=for apidoc grok_number + +Identical to grok_number_flags() with flags set to zero. + =cut */ int Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) { + PERL_ARGS_ASSERT_GROK_NUMBER; + + return grok_number_flags(pv, len, valuep, 0); +} + +int +Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) +{ const char *s = pv; const char * const send = pv + len; const UV max_div_10 = UV_MAX / 10; @@ -588,7 +597,7 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) int sawinf = 0; int sawnan = 0; - PERL_ARGS_ASSERT_GROK_NUMBER; + PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS; while (s < send && isSPACE(*s)) s++; @@ -743,9 +752,6 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) } else if (s < send) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { - /* The only flag we keep is sign. Blow away any "it's UV" */ - numtype &= IS_NUMBER_NEG; - numtype |= IS_NUMBER_NOT_INT; s++; if (s < send && (*s == '-' || *s == '+')) s++; @@ -754,8 +760,14 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) s++; } while (s < send && isDIGIT(*s)); } + else if (flags & PERL_SCAN_TRAILING) + return numtype | IS_NUMBER_TRAILING; else - return 0; + return 0; + + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; } } while (s < send && isSPACE(*s)) @@ -767,6 +779,10 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) *valuep = 0; return IS_NUMBER_IN_UV; } + else if (flags & PERL_SCAN_TRAILING) { + return numtype | IS_NUMBER_TRAILING; + } + return 0; } @@ -854,8 +870,6 @@ Perl_my_atof(pTHX_ const char* s) { NV x = 0.0; #ifdef USE_LOCALE_NUMERIC - dVAR; - PERL_ARGS_ASSERT_MY_ATOF; { diff --git a/op.c b/op.c index 2bd0fa9..e9de3a2 100644 --- a/op.c +++ b/op.c @@ -180,7 +180,6 @@ S_new_slab(pTHX_ size_t sz) void * Perl_Slab_Alloc(pTHX_ size_t sz) { - dVAR; OPSLAB *slab; OPSLAB *slab2; OPSLOT *slot; @@ -195,7 +194,10 @@ Perl_Slab_Alloc(pTHX_ size_t sz) don't use a slab, but allocate the OP directly from the heap. */ if (!PL_compcv || CvROOT(PL_compcv) || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv))) - return PerlMemShared_calloc(1, sz); + { + o = (OP*)PerlMemShared_calloc(1, sz); + goto gotit; + } /* While the subroutine is under construction, the slabs are accessed via CvSTART(), to avoid needing to expand PVCV by one pointer for something @@ -230,7 +232,7 @@ Perl_Slab_Alloc(pTHX_ size_t sz) *too = o->op_next; Zero(o, opsz, I32 *); o->op_slabbed = 1; - return (void *)o; + goto gotit; } } @@ -276,6 +278,12 @@ Perl_Slab_Alloc(pTHX_ size_t sz) slot = &slab2->opslab_slots; INIT_OPSLOT; DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab)); + + gotit: + /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */ + o->op_lastsib = 1; + assert(!o->op_sibling); + return (void *)o; } @@ -333,7 +341,6 @@ Perl_Slab_to_rw(pTHX_ OPSLAB *const slab) void Perl_Slab_Free(pTHX_ void *op) { - dVAR; OP * const o = (OP *)op; OPSLAB *slab; @@ -358,7 +365,6 @@ Perl_Slab_Free(pTHX_ void *op) void Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) { - dVAR; const bool havepad = !!PL_comppad; PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD; if (havepad) { @@ -372,7 +378,6 @@ Perl_opslab_free_nopad(pTHX_ OPSLAB *slab) void Perl_opslab_free(pTHX_ OPSLAB *slab) { - dVAR; OPSLAB *slab2; PERL_ARGS_ASSERT_OPSLAB_FREE; PERL_UNUSED_CONTEXT; @@ -583,7 +588,6 @@ S_no_bareword_allowed(pTHX_ OP *o) PADOFFSET Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) { - dVAR; PADOFFSET off; const bool is_our = (PL_parser->in_my == KEY_our); @@ -707,7 +711,9 @@ optree. void Perl_op_free(pTHX_ OP *o) { +#ifdef USE_ITHREADS dVAR; +#endif OPCODE type; /* Though ops may be freed twice, freeing the op after its slab is a @@ -753,7 +759,7 @@ Perl_op_free(pTHX_ OP *o) if (o->op_flags & OPf_KIDS) { OP *kid, *nextkid; for (kid = cUNOPo->op_first; kid; kid = nextkid) { - nextkid = kid->op_sibling; /* Get before next freeing kid */ + nextkid = OP_SIBLING(kid); /* Get before next freeing kid */ op_free(kid); } } @@ -1003,7 +1009,7 @@ S_find_and_forget_pmops(pTHX_ OP *o) forget_pmop((PMOP*)kid); } find_and_forget_pmops(kid); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); } } } @@ -1035,7 +1041,9 @@ Perl_op_null(pTHX_ OP *o) void Perl_op_refcnt_lock(pTHX) { +#ifdef USE_ITHREADS dVAR; +#endif PERL_UNUSED_CONTEXT; OP_REFCNT_LOCK; } @@ -1043,11 +1051,222 @@ Perl_op_refcnt_lock(pTHX) void Perl_op_refcnt_unlock(pTHX) { +#ifdef USE_ITHREADS dVAR; +#endif PERL_UNUSED_CONTEXT; OP_REFCNT_UNLOCK; } + +/* +=for apidoc op_sibling_splice + +A general function for editing the structure of an existing chain of +op_sibling nodes. By analogy with the perl-level splice() function, allows +you to delete zero or more sequential nodes, replacing them with zero or +more different nodes. Performs the necessary op_first/op_last +housekeeping on the parent node and op_sibling manipulation on the +children. The last deleted node will be marked as as the last node by +updating the op_sibling or op_lastsib field as appropriate. + +Note that op_next is not manipulated, and nodes are not freed; that is the +responsibility of the caller. It also won't create a new list op for an +empty list etc; use higher-level functions like op_append_elem() for that. + +parent is the parent node of the sibling chain. + +start is the node preceding the first node to be spliced. Node(s) +following it will be deleted, and ops will be inserted after it. If it is +NULL, the first node onwards is deleted, and nodes are inserted at the +beginning. + +del_count is the number of nodes to delete. If zero, no nodes are deleted. +If -1 or greater than or equal to the number of remaining kids, all +remaining kids are deleted. + +insert is the first of a chain of nodes to be inserted in place of the nodes. +If NULL, no nodes are inserted. + +The head of the chain of deleted ops is returned, or NULL if no ops were +deleted. + +For example: + + action before after returns + ------ ----- ----- ------- + + P P + splice(P, A, 2, X-Y-Z) | | B-C + A-B-C-D A-X-Y-Z-D + + P P + splice(P, NULL, 1, X-Y) | | A + A-B-C-D X-Y-B-C-D + + P P + splice(P, NULL, 3, NULL) | | A-B-C + A-B-C-D D + + P P + splice(P, B, 0, X-Y) | | NULL + A-B-C-D A-B-X-Y-C-D + +=cut +*/ + +OP * +Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) +{ + dVAR; + OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first; + OP *rest; + OP *last_del = NULL; + OP *last_ins = NULL; + + PERL_ARGS_ASSERT_OP_SIBLING_SPLICE; + + assert(del_count >= -1); + + if (del_count && first) { + last_del = first; + while (--del_count && OP_HAS_SIBLING(last_del)) + last_del = OP_SIBLING(last_del); + rest = OP_SIBLING(last_del); + OP_SIBLING_set(last_del, NULL); + last_del->op_lastsib = 1; + } + else + rest = first; + + if (insert) { + last_ins = insert; + while (OP_HAS_SIBLING(last_ins)) + last_ins = OP_SIBLING(last_ins); + OP_SIBLING_set(last_ins, rest); + last_ins->op_lastsib = rest ? 0 : 1; + } + else + insert = rest; + + if (start) { + OP_SIBLING_set(start, insert); + start->op_lastsib = insert ? 0 : 1; + } + else + cLISTOPx(parent)->op_first = insert; + + if (!rest) { + /* update op_last etc */ + U32 type = parent->op_type; + OP *lastop; + + if (type == OP_NULL) + type = parent->op_targ; + type = PL_opargs[type] & OA_CLASS_MASK; + + lastop = last_ins ? last_ins : start ? start : NULL; + if ( type == OA_BINOP + || type == OA_LISTOP + || type == OA_PMOP + || type == OA_LOOP + ) + cLISTOPx(parent)->op_last = lastop; + + if (lastop) { + lastop->op_lastsib = 1; +#ifdef PERL_OP_PARENT + lastop->op_sibling = parent; +#endif + } + } + return last_del ? first : NULL; +} + +/* +=for apidoc op_parent + +returns the parent OP of o, if it has a parent. Returns NULL otherwise. +(Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to +work. + +=cut +*/ + +OP * +Perl_op_parent(OP *o) +{ + PERL_ARGS_ASSERT_OP_PARENT; +#ifdef PERL_OP_PARENT + while (OP_HAS_SIBLING(o)) + o = OP_SIBLING(o); + return o->op_sibling; +#else + PERL_UNUSED_ARG(o); + return NULL; +#endif +} + + +/* replace the sibling following start with a new UNOP, which becomes + * the parent of the original sibling; e.g. + * + * op_sibling_newUNOP(P, A, unop-args...) + * + * P P + * | becomes | + * A-B-C A-U-C + * | + * B + * + * where U is the new UNOP. + * + * parent and start args are the same as for op_sibling_splice(); + * type and flags args are as newUNOP(). + * + * Returns the new UNOP. + */ + +OP * +S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags) +{ + OP *kid, *newop; + + kid = op_sibling_splice(parent, start, 1, NULL); + newop = newUNOP(type, flags, kid); + op_sibling_splice(parent, start, 0, newop); + return newop; +} + + +/* lowest-level newLOGOP-style function - just allocates and populates + * the struct. Higher-level stuff should be done by S_new_logop() / + * newLOGOP(). This function exists mainly to avoid op_first assignment + * being spread throughout this file. + */ + +LOGOP * +S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) +{ + LOGOP *logop; + OP *kid = first; + NewOp(1101, logop, 1, LOGOP); + logop->op_type = (OPCODE)type; + logop->op_first = first; + logop->op_other = other; + logop->op_flags = OPf_KIDS; + while (kid && OP_HAS_SIBLING(kid)) + kid = OP_SIBLING(kid); + if (kid) { + kid->op_lastsib = 1; +#ifdef PERL_OP_PARENT + kid->op_sibling = (OP*)logop; +#endif + } + return logop; +} + + /* Contextualizers */ /* @@ -1101,9 +1320,10 @@ Perl_op_linklist(pTHX_ OP *o) o->op_next = LINKLIST(first); kid = first; for (;;) { - if (kid->op_sibling) { - kid->op_next = LINKLIST(kid->op_sibling); - kid = kid->op_sibling; + OP *sibl = OP_SIBLING(kid); + if (sibl) { + kid->op_next = LINKLIST(sibl); + kid = sibl; } else { kid->op_next = o; break; @@ -1121,7 +1341,7 @@ S_scalarkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) scalar(kid); } return o; @@ -1130,8 +1350,6 @@ S_scalarkids(pTHX_ OP *o) STATIC OP * S_scalarboolean(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_SCALARBOOLEAN; if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST @@ -1208,7 +1426,7 @@ S_scalar_slice_warning(pTHX_ const OP *o) return; kid = cLISTOPo->op_first; - kid = kid->op_sibling; /* get past pushmark */ + kid = OP_SIBLING(kid); /* get past pushmark */ /* weed out false positives: any ops that can return lists */ switch (kid->op_type) { case OP_BACKTICK: @@ -1243,8 +1461,8 @@ S_scalar_slice_warning(pTHX_ const OP *o) if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST) return; - assert(kid->op_sibling); - name = S_op_varname(aTHX_ kid->op_sibling); + assert(OP_SIBLING(kid)); + name = S_op_varname(aTHX_ OP_SIBLING(kid)); if (!name) /* XS module fiddling with the op tree */ return; S_op_pretty(aTHX_ kid, &keysv, &key); @@ -1269,7 +1487,6 @@ S_scalar_slice_warning(pTHX_ const OP *o) OP * Perl_scalar(pTHX_ OP *o) { - dVAR; OP *kid; /* assumes no premature commitment */ @@ -1289,7 +1506,7 @@ Perl_scalar(pTHX_ OP *o) case OP_OR: case OP_AND: case OP_COND_EXPR: - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) scalar(kid); break; /* FALLTHROUGH */ @@ -1300,7 +1517,7 @@ Perl_scalar(pTHX_ OP *o) case OP_NULL: default: if (o->op_flags & OPf_KIDS) { - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) scalar(kid); } break; @@ -1308,10 +1525,10 @@ Perl_scalar(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; scalar(kid); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); do_kids: while (kid) { - OP *sib = kid->op_sibling; + OP *sib = OP_SIBLING(kid); if (sib && kid->op_type != OP_LEAVEWHEN) scalarvoid(kid); else @@ -1345,9 +1562,9 @@ Perl_scalar(pTHX_ OP *o) if (!ckWARN(WARN_SYNTAX)) break; kid = cLISTOPo->op_first; - kid = kid->op_sibling; /* get past pushmark */ - assert(kid->op_sibling); - name = S_op_varname(aTHX_ kid->op_sibling); + kid = OP_SIBLING(kid); /* get past pushmark */ + assert(OP_SIBLING(kid)); + name = S_op_varname(aTHX_ OP_SIBLING(kid)); if (!name) /* XS module fiddling with the op tree */ break; S_op_pretty(aTHX_ kid, &keysv, &key); @@ -1533,7 +1750,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_RV2AV: case OP_RV2HV: if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && - (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) + (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE)) useless = "a variable"; break; @@ -1660,7 +1877,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_COND_EXPR: case OP_ENTERGIVEN: case OP_ENTERWHEN: - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) scalarvoid(kid); break; @@ -1683,7 +1900,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_LIST: case OP_LEAVEGIVEN: case OP_LEAVEWHEN: - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) scalarvoid(kid); break; case OP_ENTEREVAL: @@ -1712,7 +1929,7 @@ S_listkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) list(kid); } return o; @@ -1721,7 +1938,6 @@ S_listkids(pTHX_ OP *o) OP * Perl_list(pTHX_ OP *o) { - dVAR; OP *kid; /* assumes no premature commitment */ @@ -1748,7 +1964,7 @@ Perl_list(pTHX_ OP *o) case OP_OR: case OP_AND: case OP_COND_EXPR: - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) list(kid); break; default: @@ -1769,10 +1985,10 @@ Perl_list(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; list(kid); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); do_kids: while (kid) { - OP *sib = kid->op_sibling; + OP *sib = OP_SIBLING(kid); if (sib && kid->op_type != OP_LEAVEWHEN) scalarvoid(kid); else @@ -1792,7 +2008,6 @@ Perl_list(pTHX_ OP *o) static OP * S_scalarseq(pTHX_ OP *o) { - dVAR; if (o) { const OPCODE type = o->op_type; @@ -1800,8 +2015,8 @@ S_scalarseq(pTHX_ OP *o) type == OP_LEAVE || type == OP_LEAVETRY) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { - if (kid->op_sibling) { + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) { + if (OP_HAS_SIBLING(kid)) { scalarvoid(kid); } } @@ -1821,7 +2036,7 @@ S_modkids(pTHX_ OP *o, I32 type) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) op_lvalue(kid, type); } return o; @@ -1862,23 +2077,24 @@ S_finalize_op(pTHX_ OP* o) PL_curcop = ((COP*)o); /* for warnings */ break; case OP_EXEC: - if ( o->op_sibling - && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE) - && ckWARN(WARN_EXEC)) - { - if (o->op_sibling->op_sibling) { - const OPCODE type = o->op_sibling->op_sibling->op_type; + if (OP_HAS_SIBLING(o)) { + OP *sib = OP_SIBLING(o); + if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE) + && ckWARN(WARN_EXEC) + && OP_HAS_SIBLING(sib)) + { + const OPCODE type = OP_SIBLING(sib)->op_type; if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) { const line_t oldline = CopLINE(PL_curcop); - CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling)); + CopLINE_set(PL_curcop, CopLINE((COP*)sib)); Perl_warner(aTHX_ packWARN(WARN_EXEC), "Statement unlikely to be reached"); Perl_warner(aTHX_ packWARN(WARN_EXEC), "\t(Maybe you meant system() when you said exec()?)\n"); CopLINE_set(PL_curcop, oldline); } - } } + } break; case OP_GV: @@ -1937,7 +2153,7 @@ S_finalize_op(pTHX_ OP* o) /* FALLTHROUGH */ case OP_KVHSLICE: - kid = cLISTOPo->op_first->op_sibling; + kid = OP_SIBLING(cLISTOPo->op_first); if (/* I bet there's always a pushmark... */ OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST) && OP_TYPE_ISNT_NN(kid, OP_CONST)) @@ -1947,7 +2163,7 @@ S_finalize_op(pTHX_ OP* o) key_op = (SVOP*)(kid->op_type == OP_CONST ? kid - : kLISTOP->op_first->op_sibling); + : OP_SIBLING(kLISTOP->op_first)); rop = (UNOP*)((LISTOP*)o)->op_last; @@ -1978,7 +2194,7 @@ S_finalize_op(pTHX_ OP* o) && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE)) && isGV(*fields) && GvHV(*fields); for (; key_op; - key_op = (SVOP*)key_op->op_sibling) { + key_op = (SVOP*)OP_SIBLING(key_op)) { SV **svp, *sv; if (key_op->op_type != OP_CONST) continue; @@ -2020,7 +2236,71 @@ S_finalize_op(pTHX_ OP* o) if (o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + +#ifdef DEBUGGING + /* check that op_last points to the last sibling, and that + * the last op_sibling field points back to the parent, and + * that the only ops with KIDS are those which are entitled to + * them */ + U32 type = o->op_type; + U32 family; + bool has_last; + + if (type == OP_NULL) { + type = o->op_targ; + /* ck_glob creates a null UNOP with ex-type GLOB + * (which is a list op. So pretend it wasn't a listop */ + if (type == OP_GLOB) + type = OP_NULL; + } + family = PL_opargs[type] & OA_CLASS_MASK; + + has_last = ( family == OA_BINOP + || family == OA_LISTOP + || family == OA_PMOP + || family == OA_LOOP + ); + assert( has_last /* has op_first and op_last, or ... + ... has (or may have) op_first: */ + || family == OA_UNOP + || family == OA_LOGOP + || family == OA_BASEOP_OR_UNOP + || family == OA_FILESTATOP + || family == OA_LOOPEXOP + /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */ + || type == OP_SASSIGN + || type == OP_CUSTOM + || type == OP_NULL /* new_logop does this */ + ); + /* XXX list form of 'x' is has a null op_last. This is wrong, + * but requires too much hacking (e.g. in Deparse) to fix for + * now */ + if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) { + assert(has_last); + has_last = 0; + } + + for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) { +# ifdef PERL_OP_PARENT + if (!OP_HAS_SIBLING(kid)) { + if (has_last) + assert(kid == cLISTOPo->op_last); + assert(kid->op_sibling == o); + } +# else + if (OP_HAS_SIBLING(kid)) { + assert(!kid->op_lastsib); + } + else { + assert(kid->op_lastsib); + if (has_last) + assert(kid == cLISTOPo->op_last); + } +# endif + } +#endif + + for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) finalize_op(kid); } } @@ -2121,8 +2401,8 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) (long)kid->op_type, (UV)kid->op_targ); kid = kLISTOP->op_first; } - while (kid->op_sibling) - kid = kid->op_sibling; + while (OP_HAS_SIBLING(kid)) + kid = OP_SIBLING(kid); if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { break; /* Postpone until runtime */ } @@ -2190,7 +2470,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_COND_EXPR: localize = 1; - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) op_lvalue(kid, type); break; @@ -2290,7 +2570,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; if (o->op_flags & OPf_KIDS) - op_lvalue(cBINOPo->op_first->op_sibling, type); + op_lvalue(OP_SIBLING(cBINOPo->op_first), type); break; case OP_AELEM: @@ -2330,7 +2610,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) /* FALLTHROUGH */ case OP_LIST: localize = 0; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) /* elements might be in void context because the list is in scalar context or because they are attribute sub calls */ if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID ) @@ -2351,8 +2631,8 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) || !S_vivifies(cLOGOPo->op_first->op_type)) op_lvalue(cLOGOPo->op_first, type); if (type == OP_LEAVESUBLV - || !S_vivifies(cLOGOPo->op_first->op_sibling->op_type)) - op_lvalue(cLOGOPo->op_first->op_sibling, type); + || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type)) + op_lvalue(OP_SIBLING(cLOGOPo->op_first), type); goto nomod; } @@ -2468,7 +2748,7 @@ S_refkids(pTHX_ OP *o, I32 type) { if (o && o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) ref(kid, type); } return o; @@ -2506,7 +2786,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) break; case OP_COND_EXPR: - for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid)) doref(kid, type, set_op_ref); break; case OP_RV2SV: @@ -2577,7 +2857,6 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) STATIC OP * S_dup_attrlist(pTHX_ OP *o) { - dVAR; OP *rop; PERL_ARGS_ASSERT_DUP_ATTRLIST; @@ -2591,7 +2870,7 @@ S_dup_attrlist(pTHX_ OP *o) else { assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); rop = NULL; - for (o = cLISTOPo->op_first; o; o=o->op_sibling) { + for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) { if (o->op_type == OP_CONST) rop = op_append_elem(OP_LIST, rop, newSVOP(OP_CONST, o->op_flags, @@ -2604,7 +2883,6 @@ S_dup_attrlist(pTHX_ OP *o) STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) { - dVAR; SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; PERL_ARGS_ASSERT_APPLY_ATTRS; @@ -2628,7 +2906,6 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) STATIC void S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) { - dVAR; OP *pack, *imop, *arg; SV *meth, *stashsv, **svp; @@ -2751,11 +3028,11 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) *attrs = NULL; } } else if (o->op_type == OP_LIST) { - OP * lasto = NULL; + OP * lasto; assert(o->op_flags & OPf_KIDS); - assert(cLISTOPo->op_first->op_type == OP_PUSHMARK); - /* Counting on the first op to hit the lasto = o line */ - for (o = cLISTOPo->op_first; o; o=o->op_sibling) { + lasto = cLISTOPo->op_first; + assert(lasto->op_type == OP_PUSHMARK); + for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) { if (o->op_type == OP_CONST) { pv = SvPV(cSVOPo_sv, pvlen); if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) { @@ -2774,7 +3051,9 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) else if (new_proto) op_free(new_proto); new_proto = o; - lasto->op_sibling = o->op_sibling; + /* excise new_proto from the list */ + op_sibling_splice(*attrs, lasto, 1, NULL); + o = lasto; continue; } } @@ -2782,7 +3061,7 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) } /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs would get pulled in with no real need */ - if (!cLISTOPx(*attrs)->op_first->op_sibling) { + if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) { op_free(*attrs); *attrs = NULL; } @@ -2837,7 +3116,6 @@ S_cant_declare(pTHX_ OP *o) STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) { - dVAR; I32 type; const bool stately = PL_parser && PL_parser->in_my == KEY_state; @@ -2850,7 +3128,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) if (type == OP_LIST) { OP *kid; - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) + for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) my_kid(kid, attrs, imopsp); return o; } else if (type == OP_UNDEF || type == OP_STUB) { @@ -2905,7 +3183,6 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs) { - dVAR; OP *rops; int maybe_scalar = 0; @@ -2938,7 +3215,8 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK) { OP * const pushmark = lrops->op_first; - lrops->op_first = pushmark->op_sibling; + /* excise pushmark */ + op_sibling_splice(rops, NULL, 1, NULL); op_free(pushmark); } o = op_append_list(OP_LIST, o, rops); @@ -3083,7 +3361,7 @@ Perl_op_scope(pTHX_ OP *o) op_null(kid); /* The following deals with things like 'do {1 for 1}' */ - kid = kid->op_sibling; + kid = OP_SIBLING(kid); if (kid && (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)) op_null(kid); @@ -3100,7 +3378,7 @@ Perl_op_unscope(pTHX_ OP *o) { if (o && o->op_type == OP_LINESEQ) { OP *kid = cLISTOPo->op_first; - for(; kid; kid = kid->op_sibling) + for(; kid; kid = OP_SIBLING(kid)) if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) op_null(kid); } @@ -3110,7 +3388,6 @@ Perl_op_unscope(pTHX_ OP *o) int Perl_block_start(pTHX_ int full) { - dVAR; const int retval = PL_savestack_ix; pad_block_start(full); @@ -3127,7 +3404,6 @@ Perl_block_start(pTHX_ int full) OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { - dVAR; const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; OP* retval = scalarseq(seq); OP *o; @@ -3189,7 +3465,7 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) */ OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o; OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o; - for (;; kid = kid->op_sibling) { + for (;; kid = OP_SIBLING(kid)) { OP *newkid = newOP(OP_CLONECV, 0); newkid->op_targ = kid->op_targ; o = op_append_elem(OP_LINESEQ, o, newkid); @@ -3225,7 +3501,6 @@ Perl_blockhook_register(pTHX_ BHK *hk) STATIC OP * S_newDEFSVOP(pTHX) { - dVAR; 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)); @@ -3240,8 +3515,6 @@ S_newDEFSVOP(pTHX) void Perl_newPROG(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_NEWPROG; if (PL_in_eval) { @@ -3338,8 +3611,6 @@ Perl_newPROG(pTHX_ OP *o) OP * Perl_localize(pTHX_ OP *o, I32 lex) { - dVAR; - PERL_ARGS_ASSERT_LOCALIZE; if (o->op_flags & OPf_PARENS) @@ -3496,11 +3767,11 @@ S_fold_constants(pTHX_ OP *o) #endif break; case OP_PACK: - if (!cLISTOPo->op_first->op_sibling - || cLISTOPo->op_first->op_sibling->op_type != OP_CONST) + if (!OP_HAS_SIBLING(cLISTOPo->op_first) + || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST) goto nope; { - SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling); + SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first)); if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope; { const char *s = SvPVX_const(sv); @@ -3644,34 +3915,41 @@ S_gen_constant_list(pTHX_ OP *o) o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */ o->op_opt = 0; /* needs to be revisited in rpeep() */ - curop = ((UNOP*)o)->op_first; av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--); - ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av); + + /* replace subtree with an OP_CONST */ + curop = ((UNOP*)o)->op_first; + op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av)); + op_free(curop); + if (AvFILLp(av) != -1) for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp) { SvPADTMP_on(*svp); SvREADONLY_on(*svp); } - op_free(curop); LINKLIST(o); return list(o); } +/* convert o (and any siblings) into a list if not already, then + * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it + */ + OP * Perl_convert(pTHX_ I32 type, I32 flags, OP *o) { dVAR; if (type < 0) type = -type, flags |= OPf_SPECIAL; if (!o || o->op_type != OP_LIST) - o = newLISTOP(OP_LIST, 0, o, NULL); + o = force_list(o, 0); else o->op_flags &= ~OPf_WANT; if (!(PL_opargs[type] & OA_MARK)) op_null(cLISTOPo->op_first); else { - OP * const kid2 = cLISTOPo->op_first->op_sibling; + OP * const kid2 = OP_SIBLING(cLISTOPo->op_first); if (kid2 && kid2->op_type == OP_COREARGS) { op_null(cLISTOPo->op_first); kid2->op_private |= OPpCOREARGS_PUSHMARK; @@ -3723,13 +4001,8 @@ Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last) return newLISTOP(type, 0, first, last); } - if (first->op_flags & OPf_KIDS) - ((LISTOP*)first)->op_last->op_sibling = last; - else { - first->op_flags |= OPf_KIDS; - ((LISTOP*)first)->op_first = last; - } - ((LISTOP*)first)->op_last = last; + op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last); + first->op_flags |= OPf_KIDS; return first; } @@ -3761,8 +4034,13 @@ Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last) if (last->op_type != (unsigned)type) return op_append_elem(type, first, last); - ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first; + ((LISTOP*)first)->op_last->op_lastsib = 0; + OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first); ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last; + ((LISTOP*)first)->op_last->op_lastsib = 1; +#ifdef PERL_OP_PARENT + ((LISTOP*)first)->op_last->op_sibling = first; +#endif first->op_flags |= (last->op_flags & OPf_KIDS); @@ -3795,19 +4073,13 @@ Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last) if (last->op_type == (unsigned)type) { if (type == OP_LIST) { /* already a PUSHMARK there */ - first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; - ((LISTOP*)last)->op_first->op_sibling = first; + /* insert 'first' after pushmark */ + op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first); if (!(first->op_flags & OPf_PARENS)) last->op_flags &= ~OPf_PARENS; } - else { - if (!(last->op_flags & OPf_KIDS)) { - ((LISTOP*)last)->op_last = first; - last->op_flags |= OPf_KIDS; - } - first->op_sibling = ((LISTOP*)last)->op_first; - ((LISTOP*)last)->op_first = first; - } + else + op_sibling_splice(last, NULL, 0, first); last->op_flags |= OPf_KIDS; return last; } @@ -3835,12 +4107,36 @@ Perl_newNULLLIST(pTHX) return newOP(OP_STUB, 0); } +/* promote o and any siblings to be a list if its not already; i.e. + * + * o - A - B + * + * becomes + * + * list + * | + * pushmark - o - A - B + * + * If nullit it true, the list op is nulled. + */ + static OP * -S_force_list(pTHX_ OP *o) -{ - if (!o || o->op_type != OP_LIST) +S_force_list(pTHX_ OP *o, bool nullit) +{ + if (!o || o->op_type != OP_LIST) { + OP *rest = NULL; + if (o) { + /* manually detach any siblings then add them back later */ + rest = OP_SIBLING(o); + OP_SIBLING_set(o, NULL); + o->op_lastsib = 1; + } o = newLISTOP(OP_LIST, 0, o, NULL); - op_null(o); + if (rest) + op_sibling_splice(o, cLISTOPo->op_last, 0, rest); + } + if (nullit) + op_null(o); return o; } @@ -3877,17 +4173,26 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) else if (!first && last) first = last; else if (first) - first->op_sibling = last; + OP_SIBLING_set(first, last); listop->op_first = first; listop->op_last = last; if (type == OP_LIST) { OP* const pushop = newOP(OP_PUSHMARK, 0); - pushop->op_sibling = first; + pushop->op_lastsib = 0; + OP_SIBLING_set(pushop, first); listop->op_first = pushop; listop->op_flags |= OPf_KIDS; if (!last) listop->op_last = pushop; } + if (first) + first->op_lastsib = 0; + if (listop->op_last) { + listop->op_last->op_lastsib = 1; +#ifdef PERL_OP_PARENT + listop->op_last->op_sibling = (OP*)listop; +#endif + } return CHECKOP(type, listop); } @@ -3969,7 +4274,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) if (!first) first = newOP(OP_STUB, 0); if (PL_opargs[type] & OA_MARK) - first = force_list(first); + first = force_list(first, 1); NewOp(1101, unop, 1, UNOP); unop->op_type = (OPCODE)type; @@ -3977,6 +4282,12 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) unop->op_first = first; unop->op_flags = (U8)(flags | OPf_KIDS); unop->op_private = (U8)(1 | (flags >> 8)); + +#ifdef PERL_OP_PARENT + if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */ + first->op_sibling = (OP*)unop; +#endif + unop = (UNOP*) CHECKOP(type, unop); if (unop->op_next) return (OP*)unop; @@ -4022,14 +4333,24 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) } else { binop->op_private = (U8)(2 | (flags >> 8)); - first->op_sibling = last; + OP_SIBLING_set(first, last); + first->op_lastsib = 0; } +#ifdef PERL_OP_PARENT + if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */ + last->op_sibling = (OP*)binop; +#endif + binop = (BINOP*)CHECKOP(type, binop); if (binop->op_next || binop->op_type != (OPCODE)type) return (OP*)binop; - binop->op_last = binop->op_first->op_sibling; + binop->op_last = OP_SIBLING(binop->op_first); +#ifdef PERL_OP_PARENT + if (binop->op_last) + binop->op_last->op_sibling = (OP*)binop; +#endif return fold_constants(op_integerize(op_std_init((OP *)binop))); } @@ -4054,7 +4375,6 @@ static int uvcompare(const void *a, const void *b) static OP * S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) { - dVAR; SV * const tstr = ((SVOP*)expr)->op_sv; SV * const rstr = ((SVOP*)repl)->op_sv; @@ -4490,25 +4810,27 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) OP* kid; repl = cLISTOPx(expr)->op_last; kid = cLISTOPx(expr)->op_first; - while (kid->op_sibling != repl) - kid = kid->op_sibling; - kid->op_sibling = NULL; - cLISTOPx(expr)->op_last = kid; + while (OP_SIBLING(kid) != repl) + kid = OP_SIBLING(kid); + op_sibling_splice(expr, kid, 1, NULL); } /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */ if (is_trans) { - OP* const oe = expr; - assert(expr->op_type == OP_LIST); - assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK); - assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last); - expr = cLISTOPx(oe)->op_last; - cLISTOPx(oe)->op_first->op_sibling = NULL; - cLISTOPx(oe)->op_last = NULL; - op_free(oe); + OP *first, *last; + + assert(expr->op_type == OP_LIST); + first = cLISTOPx(expr)->op_first; + last = cLISTOPx(expr)->op_last; + assert(first->op_type == OP_PUSHMARK); + assert(OP_SIBLING(first) == last); - return pmtrans(o, expr, repl); + /* cut 'last' from sibling chain, then free everything else */ + op_sibling_splice(expr, first, 1, NULL); + op_free(expr); + + return pmtrans(o, last, repl); } /* find whether we have any runtime or code elements; @@ -4521,11 +4843,11 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) has_code = 0; if (expr->op_type == OP_LIST) { OP *o; - for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { + for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) { if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) { has_code = 1; - assert(!o->op_next && o->op_sibling); - o->op_next = o->op_sibling; + assert(!o->op_next && OP_HAS_SIBLING(o)); + o->op_next = OP_SIBLING(o); } else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK) is_compiletime = 0; @@ -4541,7 +4863,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) if (expr->op_type == OP_LIST) { OP *o; - for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { + for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) { if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) { assert( !(o->op_flags & OPf_WANT)); @@ -4560,8 +4882,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first); /* skip ENTER */ assert(leaveop->op_first->op_type == OP_ENTER); - assert(leaveop->op_first->op_sibling); - o->op_next = leaveop->op_first->op_sibling; + assert(OP_HAS_SIBLING(leaveop->op_first)); + o->op_next = OP_SIBLING(leaveop->op_first); /* skip leave */ assert(leaveop->op_flags & OPf_KIDS); assert(leaveop->op_last->op_next == (OP*)leaveop); @@ -4728,18 +5050,13 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) cv_targ = expr->op_targ; expr = newUNOP(OP_REFGEN, 0, expr); - expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)))); + expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1)); } - NewOp(1101, rcop, 1, LOGOP); - rcop->op_type = OP_REGCOMP; + rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o); rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; - rcop->op_first = scalar(expr); - rcop->op_flags |= OPf_KIDS - | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) - | (reglist ? OPf_STACKED : 0); - rcop->op_private = 0; - rcop->op_other = o; + rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0) + | (reglist ? OPf_STACKED : 0); rcop->op_targ = cv_targ; /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ @@ -4765,12 +5082,14 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) /* If we are looking at s//.../e with a single statement, get past the implicit do{}. */ if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS - && cUNOPx(curop)->op_first->op_type == OP_SCOPE - && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) { + && cUNOPx(curop)->op_first->op_type == OP_SCOPE + && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) + { + OP *sib; OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first; - if (kid->op_type == OP_NULL && kid->op_sibling - && !kid->op_sibling->op_sibling) - curop = kid->op_sibling; + if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid)) + && !OP_HAS_SIBLING(sib)) + curop = sib; } if (curop->op_type == OP_CONST) konst = TRUE; @@ -4798,13 +5117,9 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) op_prepend_elem(o->op_type, scalar(repl), o); } else { - NewOp(1101, rcop, 1, LOGOP); - rcop->op_type = OP_SUBSTCONT; + rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o); rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT]; - rcop->op_first = scalar(repl); - rcop->op_flags |= OPf_KIDS; rcop->op_private = 1; - rcop->op_other = o; /* establish postfix order */ rcop->op_next = LINKLIST(repl); @@ -4918,8 +5233,6 @@ reference to it. OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { - dVAR; - PERL_ARGS_ASSERT_NEWGVOP; #ifdef USE_ITHREADS @@ -4972,7 +5285,6 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) void Perl_package(pTHX_ OP *o) { - dVAR; SV *const sv = cSVOPo->op_sv; PERL_ARGS_ASSERT_PACKAGE; @@ -4994,7 +5306,6 @@ Perl_package(pTHX_ OP *o) void Perl_package_version( pTHX_ OP *v ) { - dVAR; U32 savehints = PL_hints; PERL_ARGS_ASSERT_PACKAGE_VERSION; PL_hints &= ~HINT_STRICT_VARS; @@ -5006,7 +5317,6 @@ Perl_package_version( pTHX_ OP *v ) void Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) { - dVAR; OP *pack; OP *imop; OP *veop; @@ -5185,7 +5495,6 @@ Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) void Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) { - dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); @@ -5240,7 +5549,6 @@ S_new_entersubop(pTHX_ GV *gv, OP *arg) OP * Perl_dofile(pTHX_ OP *term, I32 force_builtin) { - dVAR; OP *doop; GV *gv; @@ -5275,8 +5583,8 @@ OP * Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval) { return newBINOP(OP_LSLICE, flags, - list(force_list(subscript)), - list(force_list(listval)) ); + list(force_list(subscript, 1)), + list(force_list(listval, 1)) ); } STATIC I32 @@ -5294,8 +5602,9 @@ S_is_list_assignment(pTHX_ const OP *o) flags = o->op_flags; type = o->op_type; if (type == OP_COND_EXPR) { - const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling); - const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling); + OP * const sib = OP_SIBLING(cLOGOPo->op_first); + const I32 t = is_list_assignment(sib); + const I32 f = is_list_assignment(OP_SIBLING(sib)); if (t && f) return TRUE; @@ -5333,7 +5642,7 @@ PERL_STATIC_INLINE bool S_aassign_common_vars(pTHX_ OP* o) { OP *curop; - for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) { + for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) { if (PL_opargs[curop->op_type] & OA_DANGEROUS) { if (curop->op_type == OP_GV) { GV *gv = cGVOPx_gv(curop); @@ -5416,7 +5725,6 @@ set as required. OP * Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) { - dVAR; OP *o; if (optype) { @@ -5442,8 +5750,8 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) PL_modcount = 0; left = op_lvalue(left, OP_AASSIGN); - curop = list(force_list(left)); - o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); + curop = list(force_list(left, 1)); + o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop); o->op_private = (U8)(0 | (flags >> 8)); if (OP_TYPE_IS_OR_WAS(left, OP_LIST)) @@ -5479,7 +5787,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) /* Other ops in the list. */ maybe_common_vars = TRUE; } - lop = lop->op_sibling; + lop = OP_SIBLING(lop); } } else if ((left->op_private & OPpLVAL_INTRO) @@ -5552,7 +5860,9 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) #endif tmpop = cUNOPo->op_first; /* to list (nulled) */ tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ - tmpop->op_sibling = NULL; /* don't free split */ + /* detach rest of siblings from o subtree, + * and free subtree */ + op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL); right->op_next = tmpop->op_next; /* fix starting loc */ op_free(o); /* blow off assign */ right->op_flags &= ~OPf_WANT; @@ -5711,8 +6021,6 @@ consumed by this function and become part of the constructed op tree. OP * Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) { - dVAR; - PERL_ARGS_ASSERT_NEWLOGOP; return new_logop(type, flags, &first, &other); @@ -5743,7 +6051,7 @@ S_search_const(pTHX_ OP *o) case OP_ENTER: case OP_NULL: case OP_NEXTSTATE: - kid = kid->op_sibling; + kid = OP_SIBLING(kid); break; default: if (kid != cLISTOPo->op_last) @@ -5870,7 +6178,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if ( ! (o2->op_type == OP_LIST && (( o2 = cUNOPx(o2)->op_first)) && o2->op_type == OP_PUSHMARK - && (( o2 = o2->op_sibling)) ) + && (( o2 = OP_SIBLING(o2))) ) ) o2 = other; if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV @@ -5893,7 +6201,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) && ckWARN(WARN_MISC)) /* [#24076] Don't warn for err FOO. */ { const OP * const k1 = ((UNOP*)first)->op_first; - const OP * const k2 = k1->op_sibling; + const OP * const k2 = OP_SIBLING(k1); OPCODE warnop = 0; switch (first->op_type) { @@ -5938,19 +6246,16 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ - NewOp(1101, logop, 1, LOGOP); - - logop->op_type = (OPCODE)type; + logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other)); logop->op_ppaddr = PL_ppaddr[type]; - logop->op_first = first; - logop->op_flags = (U8)(flags | OPf_KIDS); - logop->op_other = LINKLIST(other); + logop->op_flags |= (U8)flags; logop->op_private = (U8)(1 | (flags >> 8)); /* establish postfix order */ logop->op_next = LINKLIST(first); first->op_next = (OP*)logop; - first->op_sibling = other; + assert(!OP_HAS_SIBLING(first)); + op_sibling_splice((OP*)logop, first, 0, other); CHECKOP(type,logop); @@ -6011,13 +6316,10 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) live->op_folded = 1; return live; } - NewOp(1101, logop, 1, LOGOP); - logop->op_type = OP_COND_EXPR; + logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop)); logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; - logop->op_first = first; - logop->op_flags = (U8)(flags | OPf_KIDS); + logop->op_flags |= (U8)flags; logop->op_private = (U8)(1 | (flags >> 8)); - logop->op_other = LINKLIST(trueop); logop->op_next = LINKLIST(falseop); CHECKOP(OP_COND_EXPR, /* that's logop->op_type */ @@ -6027,8 +6329,10 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) start = LINKLIST(first); first->op_next = (OP*)logop; - first->op_sibling = trueop; - trueop->op_sibling = falseop; + /* make first, trueop, falseop siblings */ + op_sibling_splice((OP*)logop, first, 0, trueop); + op_sibling_splice((OP*)logop, trueop, 0, falseop); + o = newUNOP(OP_NULL, 0, (OP*)logop); trueop->op_next = falseop->op_next = o; @@ -6063,17 +6367,14 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) PERL_ARGS_ASSERT_NEWRANGE; - NewOp(1101, range, 1, LOGOP); - - range->op_type = OP_RANGE; + range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right)); range->op_ppaddr = PL_ppaddr[OP_RANGE]; - range->op_first = left; range->op_flags = OPf_KIDS; leftstart = LINKLIST(left); - range->op_other = LINKLIST(right); range->op_private = (U8)(1 | (flags >> 8)); - left->op_sibling = right; + /* make left and right siblings */ + op_sibling_splice((OP*)range, left, 0, right); range->op_next = (OP*)range; flip = newUNOP(OP_FLIP, flags, (OP*)range); @@ -6125,7 +6426,6 @@ unused and should always be 1. OP * Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) { - dVAR; OP* listop; OP* o; const bool once = block && block->op_flags & OPf_SPECIAL && @@ -6153,7 +6453,7 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) newASSIGNOP(0, newDEFSVOP(), 0, expr) ); } else if (expr->op_flags & OPf_KIDS) { const OP * const k1 = ((UNOP*)expr)->op_first; - const OP * const k2 = k1 ? k1->op_sibling : NULL; + const OP * const k2 = k1 ? OP_SIBLING(k1) : NULL; switch (expr->op_type) { case OP_NULL: if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) @@ -6251,7 +6551,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); } else if (expr->op_flags & OPf_KIDS) { const OP * const k1 = ((UNOP*)expr)->op_first; - const OP * const k2 = (k1) ? k1->op_sibling : NULL; + const OP * const k2 = (k1) ? OP_SIBLING(k1) : NULL; switch (expr->op_type) { case OP_NULL: if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) @@ -6410,8 +6710,9 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) } iterpflags |= OPpITER_DEF; } + if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { - expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART); + expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART); iterflags |= OPf_STACKED; } else if (expr->op_type == OP_NULL && @@ -6425,11 +6726,12 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first; LOGOP* const range = (LOGOP*) flip->op_first; OP* const left = range->op_first; - OP* const right = left->op_sibling; + OP* const right = OP_SIBLING(left); LISTOP* listop; range->op_flags &= ~OPf_KIDS; - range->op_first = NULL; + /* detach range's children */ + op_sibling_splice((OP*)range, NULL, -1, NULL); listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right); listop->op_first->op_next = range->op_next; @@ -6443,7 +6745,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) iterflags |= OPf_STACKED; } else { - expr = op_lvalue(force_list(expr), OP_GREPSTART); + expr = op_lvalue(force_list(expr, 1), OP_GREPSTART); } loop = (LOOP*)list(convert(OP_ENTERITER, iterflags, @@ -6459,6 +6761,10 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) LOOP *tmp; NewOp(1234,tmp,1,LOOP); Copy(loop,tmp,1,LISTOP); +#ifdef PERL_OP_PARENT + assert(loop->op_last->op_sibling == (OP*)loop); + loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */ +#endif S_op_destroy(aTHX_ (OP*)loop); loop = tmp; } @@ -6483,7 +6789,6 @@ becomes part of the constructed op tree. OP* Perl_newLOOPEX(pTHX_ I32 type, OP *label) { - dVAR; OP *o = NULL; PERL_ARGS_ASSERT_NEWLOOPEX; @@ -6578,25 +6883,22 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, PERL_ARGS_ASSERT_NEWGIVWHENOP; - NewOp(1101, enterop, 1, LOGOP); - enterop->op_type = (Optype)enter_opcode; + enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL); enterop->op_ppaddr = PL_ppaddr[enter_opcode]; - enterop->op_flags = (U8) OPf_KIDS; enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg); enterop->op_private = 0; o = newUNOP(leave_opcode, 0, (OP *) enterop); if (cond) { - enterop->op_first = scalar(cond); - cond->op_sibling = block; + /* prepend cond if we have one */ + op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond)); o->op_next = LINKLIST(cond); cond->op_next = (OP *) enterop; } else { /* This is a default {} block */ - enterop->op_first = block; enterop->op_flags |= OPf_SPECIAL; o ->op_flags |= OPf_SPECIAL; @@ -6627,8 +6929,6 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, STATIC bool S_looks_like_bool(pTHX_ const OP *o) { - dVAR; - PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL; switch(o->op_type) { @@ -6637,9 +6937,13 @@ S_looks_like_bool(pTHX_ const OP *o) return looks_like_bool(cLOGOPo->op_first); case OP_AND: + { + OP* sibl = OP_SIBLING(cLOGOPo->op_first); + ASSUME(sibl); return ( looks_like_bool(cLOGOPo->op_first) - && looks_like_bool(cLOGOPo->op_first->op_sibling)); + && looks_like_bool(sibl)); + } case OP_NULL: case OP_SCALAR: @@ -6709,7 +7013,6 @@ be affected. If it is 0, the global $_ will be used. OP * Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) { - dVAR; PERL_ARGS_ASSERT_NEWGIVENOP; return newGIVWHENOP( ref_array_or_hash(cond), @@ -6829,10 +7132,9 @@ L. =cut */ SV * -Perl_cv_const_sv(pTHX_ const CV *const cv) +Perl_cv_const_sv(const CV *const cv) { SV *sv; - PERL_UNUSED_CONTEXT; if (!cv) return NULL; if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)) @@ -6843,9 +7145,8 @@ Perl_cv_const_sv(pTHX_ const CV *const cv) } SV * -Perl_cv_const_sv_or_av(pTHX_ const CV * const cv) +Perl_cv_const_sv_or_av(const CV * const cv) { - PERL_UNUSED_CONTEXT; if (!cv) return NULL; assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); @@ -6876,14 +7177,13 @@ Perl_cv_const_sv_or_av(pTHX_ const CV * const cv) SV * Perl_op_const_sv(pTHX_ const OP *o, CV *cv) { - dVAR; SV *sv = NULL; if (!o) return NULL; if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) - o = cLISTOPo->op_first->op_sibling; + o = OP_SIBLING(cLISTOPo->op_first); for (; o; o = o->op_next) { const OPCODE type = o->op_type; @@ -6984,7 +7284,6 @@ S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, CV * Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { - dVAR; CV **spot; SV **svspot; const char *ps; @@ -7325,7 +7624,6 @@ CV * Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block, bool o_is_gv) { - dVAR; GV *gv; const char *ps; STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */ @@ -7756,7 +8054,6 @@ CV * Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags, SV *sv) { - dVAR; CV* cv; const char *const file = CopFILE(PL_curcop); @@ -7936,7 +8233,6 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) void Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { - dVAR; CV *cv; GV *gv; @@ -8207,12 +8503,15 @@ Perl_ck_backtick(pTHX_ OP *o) { GV *gv; OP *newop = NULL; + OP *sibl; PERL_ARGS_ASSERT_CK_BACKTICK; /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */ - if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_sibling - && (gv = gv_override("readpipe",8))) { - newop = S_new_entersubop(aTHX_ gv, cUNOPo->op_first->op_sibling); - cUNOPo->op_first->op_sibling = NULL; + if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first)) + && (gv = gv_override("readpipe",8))) + { + /* detach rest of siblings from o and its first child */ + op_sibling_splice(o, cUNOPo->op_first, -1, NULL); + newop = S_new_entersubop(aTHX_ gv, sibl); } else if (!(o->op_flags & OPf_KIDS)) newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); @@ -8227,8 +8526,6 @@ Perl_ck_backtick(pTHX_ OP *o) OP * Perl_ck_bitop(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_CK_BITOP; o->op_private = (U8)(PL_hints & HINT_INTEGER); @@ -8238,7 +8535,7 @@ Perl_ck_bitop(pTHX_ OP *o) || o->op_type == OP_BIT_XOR)) { const OP * const left = cBINOPo->op_first; - const OP * const right = left->op_sibling; + const OP * const right = OP_SIBLING(left); if ((OP_IS_NUMCOMPARE(left->op_type) && (left->op_flags & OPf_PARENS) == 0) || (OP_IS_NUMCOMPARE(right->op_type) && @@ -8256,6 +8553,7 @@ PERL_STATIC_INLINE bool is_dollar_bracket(pTHX_ const OP * const o) { const OP *kid; + PERL_UNUSED_CONTEXT; return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS && (kid = cUNOPx(o)->op_first) && kid->op_type == OP_GV @@ -8268,14 +8566,16 @@ Perl_ck_cmp(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_CMP; if (ckWARN(WARN_SYNTAX)) { const OP *kid = cUNOPo->op_first; - if (kid && ( - ( - is_dollar_bracket(aTHX_ kid) - && kid->op_sibling && kid->op_sibling->op_type == OP_CONST + if (kid && + ( + ( is_dollar_bracket(aTHX_ kid) + && OP_SIBLING(kid) && OP_SIBLING(kid)->op_type == OP_CONST ) - || ( kid->op_type == OP_CONST - && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid)) - )) + || ( kid->op_type == OP_CONST + && (kid = OP_SIBLING(kid)) && is_dollar_bracket(aTHX_ kid) + ) + ) + ) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "$[ used in %s (did you mean $] ?)", OP_DESC(o)); } @@ -8306,19 +8606,22 @@ Perl_ck_spair(pTHX_ OP *o) if (o->op_flags & OPf_KIDS) { OP* newop; OP* kid; + OP* kidkid; const OPCODE type = o->op_type; o = modkids(ck_fun(o), type); - kid = cUNOPo->op_first; - newop = kUNOP->op_first->op_sibling; + kid = cUNOPo->op_first; + kidkid = kUNOP->op_first; + newop = OP_SIBLING(kidkid); if (newop) { const OPCODE type = newop->op_type; - if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) || + if (OP_HAS_SIBLING(newop) || !(PL_opargs[type] & OA_RETSCALAR) || type == OP_PADAV || type == OP_PADHV || type == OP_RV2AV || type == OP_RV2HV) return o; } - op_free(kUNOP->op_first); - kUNOP->op_first = newop; + /* excise first sibling */ + op_sibling_splice(kid, NULL, 1, NULL); + op_free(kidkid); } /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP, * and OP_CHOMP into OP_SCHOMP */ @@ -8367,8 +8670,6 @@ Perl_ck_delete(pTHX_ OP *o) OP * Perl_ck_eof(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_CK_EOF; if (o->op_flags & OPf_KIDS) { @@ -8402,13 +8703,12 @@ Perl_ck_eval(pTHX_ OP *o) if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { LOGOP *enter; - cUNOPo->op_first = 0; + /* cut whole sibling chain free from o */ + op_sibling_splice(o, NULL, -1, NULL); op_free(o); - NewOp(1101, enter, 1, LOGOP); - enter->op_type = OP_ENTERTRY; + enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL); enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY]; - enter->op_private = 0; /* establish postfix order */ enter->op_next = (OP*)enter; @@ -8427,7 +8727,11 @@ Perl_ck_eval(pTHX_ OP *o) else { const U8 priv = o->op_private; op_free(o); - o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP()); + /* the newUNOP will recursively call ck_eval(), which will handle + * all the stuff at the end of this function, like adding + * OP_HINTSEVAL + */ + return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP()); } o->op_targ = (PADOFFSET)PL_hints; if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8; @@ -8436,7 +8740,9 @@ Perl_ck_eval(pTHX_ OP *o) /* Store a copy of %^H that pp_entereval can pick up. */ OP *hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv)))); - cUNOPo->op_first->op_sibling = hhop; + /* append hhop to only child */ + op_sibling_splice(o, cUNOPo->op_first, 0, hhop); + o->op_private |= OPpEVAL_HAS_HH; } if (!(o->op_private & OPpEVAL_BYTES) @@ -8453,7 +8759,7 @@ Perl_ck_exec(pTHX_ OP *o) if (o->op_flags & OPf_STACKED) { OP *kid; o = ck_fun(o); - kid = cUNOPo->op_first->op_sibling; + kid = OP_SIBLING(cUNOPo->op_first); if (kid->op_type == OP_RV2GV) op_null(kid); } @@ -8465,8 +8771,6 @@ Perl_ck_exec(pTHX_ OP *o) OP * Perl_ck_exists(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_CK_EXISTS; o = ck_fun(o); @@ -8649,7 +8953,6 @@ Perl_ck_ftst(pTHX_ OP *o) OP * Perl_ck_fun(pTHX_ OP *o) { - dVAR; const int type = o->op_type; I32 oa = PL_opargs[type] >> OASHIFT; @@ -8663,17 +8966,16 @@ Perl_ck_fun(pTHX_ OP *o) } if (o->op_flags & OPf_KIDS) { - OP **tokid = &cLISTOPo->op_first; + OP *prev_kid = NULL; OP *kid = cLISTOPo->op_first; - OP *sibl; I32 numargs = 0; bool seen_optional = FALSE; if (kid->op_type == OP_PUSHMARK || (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) { - tokid = &kid->op_sibling; - kid = kid->op_sibling; + prev_kid = kid; + kid = OP_SIBLING(kid); } if (kid && kid->op_type == OP_COREARGS) { bool optional = FALSE; @@ -8688,14 +8990,16 @@ Perl_ck_fun(pTHX_ OP *o) while (oa) { if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) { - if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) - *tokid = kid = newDEFSVOP(); + if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) { + kid = newDEFSVOP(); + /* append kid to chain */ + op_sibling_splice(o, prev_kid, 0, kid); + } seen_optional = TRUE; } if (!kid) break; numargs++; - sibl = kid->op_sibling; switch (oa & 7) { case OA_SCALAR: /* list seen where single (scalar) arg expected? */ @@ -8716,7 +9020,7 @@ Perl_ck_fun(pTHX_ OP *o) break; case OA_AVREF: if ((type == OP_PUSH || type == OP_UNSHIFT) - && !kid->op_sibling) + && !OP_HAS_SIBLING(kid)) Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Useless use of %s with no values", PL_op_desc[type]); @@ -8745,12 +9049,11 @@ Perl_ck_fun(pTHX_ OP *o) break; case OA_CVREF: { - OP * const newop = newUNOP(OP_NULL, 0, kid); - kid->op_sibling = 0; + /* replace kid with newop in chain */ + OP * const newop = + S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0); newop->op_next = newop; kid = newop; - kid->op_sibling = sibl; - *tokid = kid; } break; case OA_FILEREF: @@ -8760,9 +9063,8 @@ Perl_ck_fun(pTHX_ OP *o) { OP * const newop = newGVOP(OP_GV, 0, gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO)); - if (!(o->op_private & 1) && /* if not unop */ - kid == cLISTOPo->op_last) - cLISTOPo->op_last = newop; + /* replace kid with newop in chain */ + op_sibling_splice(o, prev_kid, 1, newop); op_free(kid); kid = newop; } @@ -8863,13 +9165,12 @@ Perl_ck_fun(pTHX_ OP *o) if ( name_utf8 ) SvUTF8_on(namesv); } } - kid->op_sibling = 0; - kid = newUNOP(OP_RV2GV, flags, scalar(kid)); - kid->op_targ = targ; - kid->op_private |= priv; + scalar(kid); + kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid, + OP_RV2GV, flags); + kid->op_targ = targ; + kid->op_private |= priv; } - kid->op_sibling = sibl; - *tokid = kid; } scalar(kid); break; @@ -8882,8 +9183,8 @@ Perl_ck_fun(pTHX_ OP *o) break; } oa >>= 4; - tokid = &kid->op_sibling; - kid = kid->op_sibling; + prev_kid = kid; + kid = OP_SIBLING(kid); } /* FIXME - should the numargs or-ing move after the too many * arguments check? */ @@ -8910,13 +9211,12 @@ Perl_ck_fun(pTHX_ OP *o) OP * Perl_ck_glob(pTHX_ OP *o) { - dVAR; GV *gv; PERL_ARGS_ASSERT_CK_GLOB; o = ck_fun(o); - if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) + if ((o->op_flags & OPf_KIDS) && !OP_HAS_SIBLING(cLISTOPo->op_first)) op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */ if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4))) @@ -8973,12 +9273,12 @@ Perl_ck_grep(pTHX_ OP *o) /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */ if (o->op_flags & OPf_STACKED) { - kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first; + kid = cUNOPx(OP_SIBLING(cLISTOPo->op_first))->op_first; if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE) return no_fh_allowed(o); o->op_flags &= ~OPf_STACKED; } - kid = cLISTOPo->op_first->op_sibling; + kid = OP_SIBLING(cLISTOPo->op_first); if (type == OP_MAPWHILE) list(kid); else @@ -8986,17 +9286,13 @@ Perl_ck_grep(pTHX_ OP *o) o = ck_fun(o); if (PL_parser && PL_parser->error_count) return o; - kid = cLISTOPo->op_first->op_sibling; + kid = OP_SIBLING(cLISTOPo->op_first); if (kid->op_type != OP_NULL) Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type); kid = kUNOP->op_first; - NewOp(1101, gwop, 1, LOGOP); - gwop->op_type = type; + gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid)); gwop->op_ppaddr = PL_ppaddr[type]; - gwop->op_first = o; - gwop->op_flags |= OPf_KIDS; - gwop->op_other = LINKLIST(kid); kid->op_next = (OP*)gwop; offset = pad_findmy_pvs("$_", 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { @@ -9008,8 +9304,8 @@ Perl_ck_grep(pTHX_ OP *o) gwop->op_targ = o->op_targ = offset; } - kid = cLISTOPo->op_first->op_sibling; - for (kid = kid->op_sibling; kid; kid = kid->op_sibling) + kid = OP_SIBLING(cLISTOPo->op_first); + for (kid = OP_SIBLING(kid); kid; kid = OP_SIBLING(kid)) op_lvalue(kid, OP_GREPSTART); return (OP*)gwop; @@ -9021,9 +9317,9 @@ Perl_ck_index(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_INDEX; if (o->op_flags & OPf_KIDS) { - OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ if (kid) - kid = kid->op_sibling; /* get past "big" */ + kid = OP_SIBLING(kid); /* get past "big" */ if (kid && kid->op_type == OP_CONST) { const bool save_taint = TAINT_get; SV *sv = kSVOP->op_sv; @@ -9116,21 +9412,22 @@ Perl_ck_listiob(pTHX_ OP *o) kid = cLISTOPo->op_first; if (!kid) { - o = force_list(o); + o = force_list(o, 1); kid = cLISTOPo->op_first; } if (kid->op_type == OP_PUSHMARK) - kid = kid->op_sibling; + kid = OP_SIBLING(kid); if (kid && o->op_flags & OPf_STACKED) - kid = kid->op_sibling; - else if (kid && !kid->op_sibling) { /* print HANDLE; */ + kid = OP_SIBLING(kid); + else if (kid && !OP_HAS_SIBLING(kid)) { /* print HANDLE; */ if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE && !kid->op_folded) { o->op_flags |= OPf_STACKED; /* make it a filehandle */ - kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); - cLISTOPo->op_first->op_sibling = kid; - cLISTOPo->op_last = kid; - kid = kid->op_sibling; + scalar(kid); + /* replace old const op with new OP_RV2GV parent */ + kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first, + OP_RV2GV, OPf_REF); + kid = OP_SIBLING(kid); } } @@ -9148,12 +9445,19 @@ Perl_ck_smartmatch(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SMARTMATCH; if (0 == (o->op_flags & OPf_SPECIAL)) { OP *first = cBINOPo->op_first; - OP *second = first->op_sibling; + OP *second = OP_SIBLING(first); /* Implicitly take a reference to an array or hash */ - first->op_sibling = NULL; - first = cBINOPo->op_first = ref_array_or_hash(first); - second = first->op_sibling = ref_array_or_hash(second); + + /* remove the original two siblings, then add back the + * (possibly different) first and second sibs. + */ + op_sibling_splice(o, NULL, 1, NULL); + op_sibling_splice(o, NULL, 1, NULL); + first = ref_array_or_hash(first); + second = ref_array_or_hash(second); + op_sibling_splice(o, NULL, 0, second); + op_sibling_splice(o, NULL, 0, first); /* Implicitly take a reference to a regular expression */ if (first->op_type == OP_MATCH) { @@ -9185,7 +9489,7 @@ Perl_ck_sassign(pTHX_ OP *o) && !(kid->op_private & OPpTARGET_MY) ) { - OP * const kkid = kid->op_sibling; + OP * const kkid = OP_SIBLING(kid); /* Can just relocate the target. */ if (kkid && kkid->op_type == OP_PADSV @@ -9193,17 +9497,19 @@ Perl_ck_sassign(pTHX_ OP *o) { kid->op_targ = kkid->op_targ; kkid->op_targ = 0; - /* Now we do not need PADSV and SASSIGN. */ - kid->op_sibling = o->op_sibling; /* NULL */ - cLISTOPo->op_first = NULL; + /* Now we do not need PADSV and SASSIGN. + * first replace the PADSV with OP_SIBLING(o), then + * detach kid and OP_SIBLING(o) from o */ + op_sibling_splice(o, kid, 1, OP_SIBLING(o)); + op_sibling_splice(o, NULL, -1, NULL); op_free(o); op_free(kkid); kid->op_private |= OPpTARGET_MY; /* Used for context settings */ return kid; } } - if (kid->op_sibling) { - OP *kkid = kid->op_sibling; + if (OP_HAS_SIBLING(kid)) { + OP *kkid = OP_SIBLING(kid); /* For state variable assignment, kkid is a list op whose op_last is a padsv. */ if ((kkid->op_type == OP_PADSV || @@ -9212,7 +9518,7 @@ Perl_ck_sassign(pTHX_ OP *o) ) ) && (kkid->op_private & OPpLVAL_INTRO) - && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) { + && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) { const PADOFFSET target = kkid->op_targ; OP *const other = newOP(OP_PADSV, kkid->op_flags @@ -9229,10 +9535,14 @@ Perl_ck_sassign(pTHX_ OP *o) other->op_targ = target; /* Because we change the type of the op here, we will skip the - assignment binop->op_last = binop->op_first->op_sibling; at the + assignment binop->op_last = OP_SIBLING(binop->op_first); at the end of Perl_newBINOP(). So need to do it here. */ - cBINOPo->op_last = cBINOPo->op_first->op_sibling; - + cBINOPo->op_last = OP_SIBLING(cBINOPo->op_first); + cBINOPo->op_first->op_lastsib = 0; + cBINOPo->op_last ->op_lastsib = 1; +#ifdef PERL_OP_PARENT + cBINOPo->op_last->op_sibling = o; +#endif return nullop; } } @@ -9242,8 +9552,6 @@ Perl_ck_sassign(pTHX_ OP *o) OP * Perl_ck_match(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_CK_MATCH; if (o->op_type != OP_QR && PL_compcv) { @@ -9295,8 +9603,6 @@ Perl_ck_null(pTHX_ OP *o) OP * Perl_ck_open(pTHX_ OP *o) { - dVAR; - PERL_ARGS_ASSERT_CK_OPEN; S_io_hints(aTHX_ o); @@ -9311,13 +9617,13 @@ Perl_ck_open(pTHX_ OP *o) if ((last->op_type == OP_CONST) && /* The bareword. */ (last->op_private & OPpCONST_BARE) && (last->op_private & OPpCONST_STRICT) && - (oa = first->op_sibling) && /* The fh. */ - (oa = oa->op_sibling) && /* The mode. */ + (oa = OP_SIBLING(first)) && /* The fh. */ + (oa = OP_SIBLING(oa)) && /* The mode. */ (oa->op_type == OP_CONST) && SvPOK(((SVOP*)oa)->op_sv) && (mode = SvPVX_const(((SVOP*)oa)->op_sv)) && mode[0] == '>' && mode[1] == '&' && /* A dup open. */ - (last == oa->op_sibling)) /* The bareword. */ + (last == OP_SIBLING(oa))) /* The bareword. */ last->op_private &= ~OPpCONST_STRICT; } return ck_fun(o); @@ -9329,8 +9635,11 @@ Perl_ck_repeat(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_REPEAT; if (cBINOPo->op_first->op_flags & OPf_PARENS) { + OP* kids; o->op_private |= OPpREPEAT_DOLIST; - cBINOPo->op_first = force_list(cBINOPo->op_first); + kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */ + kids = force_list(kids, 1); /* promote them to a list */ + op_sibling_splice(o, NULL, 0, kids); /* and add back */ } else scalar(o); @@ -9340,7 +9649,6 @@ Perl_ck_repeat(pTHX_ OP *o) OP * Perl_ck_require(pTHX_ OP *o) { - dVAR; GV* gv; PERL_ARGS_ASSERT_CK_REQUIRE; @@ -9382,7 +9690,7 @@ Perl_ck_require(pTHX_ OP *o) OP *kid, *newop; if (o->op_flags & OPf_KIDS) { kid = cUNOPo->op_first; - cUNOPo->op_first = NULL; + op_sibling_splice(o, NULL, -1, NULL); } else { kid = newDEFSVOP(); @@ -9398,14 +9706,13 @@ Perl_ck_require(pTHX_ OP *o) OP * Perl_ck_return(pTHX_ OP *o) { - dVAR; OP *kid; PERL_ARGS_ASSERT_CK_RETURN; - kid = cLISTOPo->op_first->op_sibling; + kid = OP_SIBLING(cLISTOPo->op_first); if (CvLVALUE(PL_compcv)) { - for (; kid; kid = kid->op_sibling) + for (; kid; kid = OP_SIBLING(kid)) op_lvalue(kid, OP_LEAVESUBLV); } @@ -9421,8 +9728,8 @@ Perl_ck_select(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SELECT; if (o->op_flags & OPf_KIDS) { - kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ - if (kid && kid->op_sibling) { + kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ + if (kid && OP_HAS_SIBLING(kid)) { o->op_type = OP_SSELECT; o->op_ppaddr = PL_ppaddr[OP_SSELECT]; o = ck_fun(o); @@ -9430,7 +9737,7 @@ Perl_ck_select(pTHX_ OP *o) } } o = ck_fun(o); - kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ if (kid && kid->op_type == OP_RV2GV) kid->op_private &= ~HINT_STRICT_REFS; return o; @@ -9439,7 +9746,6 @@ Perl_ck_select(pTHX_ OP *o) OP * Perl_ck_shift(pTHX_ OP *o) { - dVAR; const I32 type = o->op_type; PERL_ARGS_ASSERT_CK_SHIFT; @@ -9462,7 +9768,6 @@ Perl_ck_shift(pTHX_ OP *o) OP * Perl_ck_sort(pTHX_ OP *o) { - dVAR; OP *firstkid; OP *kid; HV * const hinthv = @@ -9484,7 +9789,7 @@ Perl_ck_sort(pTHX_ OP *o) if (o->op_flags & OPf_STACKED) simplify_sort(o); - firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + firstkid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */ OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ @@ -9504,10 +9809,10 @@ Perl_ck_sort(pTHX_ OP *o) o->op_flags |= OPf_SPECIAL; } - firstkid = firstkid->op_sibling; + firstkid = OP_SIBLING(firstkid); } - for (kid = firstkid; kid; kid = kid->op_sibling) { + for (kid = firstkid; kid; kid = OP_SIBLING(kid)) { /* provide list context for arguments */ list(kid); if (stacked) @@ -9530,8 +9835,7 @@ Perl_ck_sort(pTHX_ OP *o) STATIC void S_simplify_sort(pTHX_ OP *o) { - dVAR; - OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */ OP *k; int descending; GV *gv; @@ -9573,7 +9877,7 @@ S_simplify_sort(pTHX_ OP *o) kid = kBINOP->op_first; do { if (kid->op_type == OP_PADSV) { - SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ]; + SV * const name = PAD_COMPNAME_SV(kid->op_targ); if (SvCUR(name) == 2 && *SvPVX(name) == '$' && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b')) /* diag_listed_as: "my %s" used in sort comparison */ @@ -9582,7 +9886,7 @@ S_simplify_sort(pTHX_ OP *o) SvPAD_STATE(name) ? "state" : "my", SvPVX(name)); } - } while ((kid = kid->op_sibling)); + } while ((kid = OP_SIBLING(kid))); return; } kid = kBINOP->op_first; /* get past cmp */ @@ -9621,9 +9925,10 @@ S_simplify_sort(pTHX_ OP *o) o->op_private |= OPpSORT_NUMERIC; if (k->op_type == OP_I_NCMP) o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; - kid = cLISTOPo->op_first->op_sibling; - cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ - op_free(kid); /* then delete it */ + kid = OP_SIBLING(cLISTOPo->op_first); + /* cut out and delete old block (second sibling) */ + op_sibling_splice(o, cLISTOPo->op_first, 1, NULL); + op_free(kid); } OP * @@ -9640,23 +9945,18 @@ Perl_ck_split(pTHX_ OP *o) kid = cLISTOPo->op_first; if (kid->op_type != OP_NULL) Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type); - kid = kid->op_sibling; - op_free(cLISTOPo->op_first); - if (kid) - cLISTOPo->op_first = kid; - else { - cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" ")); - cLISTOPo->op_last = kid; /* There was only one element previously */ - } + /* delete leading NULL node, then add a CONST if no other nodes */ + op_sibling_splice(o, NULL, 1, + OP_HAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" "))); + op_free(kid); + kid = cLISTOPo->op_first; if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { - OP * const sibl = kid->op_sibling; - kid->op_sibling = 0; - kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */ - if (cLISTOPo->op_first == cLISTOPo->op_last) - cLISTOPo->op_last = kid; - cLISTOPo->op_first = kid; - kid->op_sibling = sibl; + /* remove kid, and replace with new optree */ + op_sibling_splice(o, NULL, 1, NULL); + /* OPf_SPECIAL is used to trigger split " " behavior */ + kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); + op_sibling_splice(o, NULL, 0, kid); } kid->op_type = OP_PUSHRE; @@ -9667,24 +9967,24 @@ Perl_ck_split(pTHX_ OP *o) "Use of /g modifier is meaningless in split"); } - if (!kid->op_sibling) + if (!OP_HAS_SIBLING(kid)) op_append_elem(OP_SPLIT, o, newDEFSVOP()); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); assert(kid); scalar(kid); - if (!kid->op_sibling) + if (!OP_HAS_SIBLING(kid)) { op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); o->op_private |= OPpSPLIT_IMPLIM; } - assert(kid->op_sibling); + assert(OP_HAS_SIBLING(kid)); - kid = kid->op_sibling; + kid = OP_SIBLING(kid); scalar(kid); - if (kid->op_sibling) + if (OP_HAS_SIBLING(kid)) return too_many_arguments_pv(o,OP_DESC(o), 0); return o; @@ -9693,7 +9993,7 @@ Perl_ck_split(pTHX_ OP *o) OP * Perl_ck_join(pTHX_ OP *o) { - const OP * const kid = cLISTOPo->op_first->op_sibling; + const OP * const kid = OP_SIBLING(cLISTOPo->op_first); PERL_ARGS_ASSERT_CK_JOIN; @@ -9844,9 +10144,9 @@ Perl_ck_entersub_args_list(pTHX_ OP *entersubop) OP *aop; PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST; aop = cUNOPx(entersubop)->op_first; - if (!aop->op_sibling) + if (!OP_HAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) { + for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) { list(aop); op_lvalue(aop, OP_ENTERSUB); } @@ -9886,7 +10186,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) { STRLEN proto_len; const char *proto, *proto_end; - OP *aop, *prev, *cvop; + OP *aop, *prev, *cvop, *parent; int optional = 0; I32 arg = 0; I32 contextclass = 0; @@ -9900,12 +10200,15 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) else proto = SvPV(protosv, proto_len); proto = S_strip_spaces(aTHX_ proto, &proto_len); proto_end = proto + proto_len; + parent = entersubop; aop = cUNOPx(entersubop)->op_first; - if (!aop->op_sibling) + if (!OP_HAS_SIBLING(aop)) { + parent = aop; aop = cUNOPx(aop)->op_first; + } prev = aop; - aop = aop->op_sibling; - for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; + aop = OP_SIBLING(aop); + for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; while (aop != cvop) { OP* o3 = aop; @@ -9954,21 +10257,22 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (gvop && gvop->op_type == OP_NULL) { gvop = ((UNOP*)gvop)->op_first; if (gvop) { - for (; gvop->op_sibling; gvop = gvop->op_sibling) + for (; OP_HAS_SIBLING(gvop); gvop = OP_SIBLING(gvop)) ; if (gvop && (gvop->op_private & OPpENTERSUB_NOPAREN) && (gvop = ((UNOP*)gvop)->op_first) && gvop->op_type == OP_GV) { + OP * newop; GV * const gv = cGVOPx_gv(gvop); - OP * const sibling = aop->op_sibling; SV * const n = newSVpvs(""); - op_free(aop); gv_fullname4(n, gv, "", FALSE); - aop = newSVOP(OP_CONST, 0, n); - prev->op_sibling = aop; - aop->op_sibling = sibling; + /* replace the aop subtree with a const op */ + newop = newSVOP(OP_CONST, 0, n); + op_sibling_splice(parent, prev, 1, newop); + op_free(aop); + aop = newop; } } } @@ -10068,14 +10372,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) bad_type_gv(arg, "hash", namegv, 0, o3); break; wrapref: - { - OP* const kid = aop; - OP* const sib = kid->op_sibling; - kid->op_sibling = 0; - aop = newUNOP(OP_REFGEN, 0, kid); - aop->op_sibling = sib; - prev->op_sibling = aop; - } + aop = S_op_sibling_newUNOP(aTHX_ parent, prev, + OP_REFGEN, 0); if (contextclass && e) { proto = e + 1; contextclass = 0; @@ -10100,13 +10398,11 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) op_lvalue(aop, OP_ENTERSUB); prev = aop; - aop = aop->op_sibling; + aop = OP_SIBLING(aop); } if (aop == cvop && *proto == '_') { /* generate an access to $_ */ - aop = newDEFSVOP(); - aop->op_sibling = prev->op_sibling; - prev->op_sibling = aop; /* instead of cvop */ + op_sibling_splice(parent, prev, 0, newDEFSVOP()); } if (!optional && proto_end > proto && (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) @@ -10162,10 +10458,10 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (!opnum) { OP *cvop; - if (!aop->op_sibling) + if (!OP_HAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - aop = aop->op_sibling; - for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; + aop = OP_SIBLING(aop); + for (cvop = aop; OP_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; if (aop != cvop) (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0); @@ -10189,22 +10485,33 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) NOT_REACHED; } else { - OP *prev, *cvop; + OP *prev, *cvop, *first, *parent; U32 flags; - if (!aop->op_sibling) + + parent = entersubop; + if (!OP_HAS_SIBLING(aop)) { + parent = aop; aop = cUNOPx(aop)->op_first; + } - prev = aop; - aop = aop->op_sibling; - prev->op_sibling = NULL; + first = prev = aop; + aop = OP_SIBLING(aop); + /* find last sibling */ for (cvop = aop; - cvop->op_sibling; - prev=cvop, cvop = cvop->op_sibling) + OP_HAS_SIBLING(cvop); + prev = cvop, cvop = OP_SIBLING(cvop)) ; - prev->op_sibling = NULL; flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN); + /* excise cvop from end of sibling chain */ + op_sibling_splice(parent, prev, 1, NULL); op_free(cvop); if (aop == cvop) aop = NULL; + + /* detach remaining siblings from the first sibling, then + * dispose of original optree */ + + if (aop) + op_sibling_splice(parent, first, -1, NULL); op_free(entersubop); if (opnum == OP_ENTEREVAL @@ -10267,6 +10574,7 @@ Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) { MAGIC *callmg; PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; + PERL_UNUSED_CONTEXT; callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL; if (callmg) { *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); @@ -10343,10 +10651,10 @@ Perl_ck_subr(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SUBR; aop = cUNOPx(o)->op_first; - if (!aop->op_sibling) + if (!OP_HAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - aop = aop->op_sibling; - for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; + aop = OP_SIBLING(aop); + for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL; @@ -10362,7 +10670,7 @@ Perl_ck_subr(pTHX_ OP *o) if (aop->op_type == OP_CONST) aop->op_private &= ~OPpCONST_STRICT; else if (aop->op_type == OP_LIST) { - OP * const sib = ((UNOP*)aop)->op_first->op_sibling; + OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first); if (sib && sib->op_type == OP_CONST) sib->op_private &= ~OPpCONST_STRICT; } @@ -10428,7 +10736,7 @@ Perl_ck_trunc(pTHX_ OP *o) SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_NULL) - kid = (SVOP*)kid->op_sibling; + kid = (SVOP*)OP_SIBLING(kid); if (kid && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE) && !kid->op_folded) @@ -10450,7 +10758,7 @@ Perl_ck_substr(pTHX_ OP *o) OP *kid = cLISTOPo->op_first; if (kid->op_type == OP_NULL) - kid = kid->op_sibling; + kid = OP_SIBLING(kid); if (kid) kid->op_flags |= OPf_MOD; @@ -10465,7 +10773,7 @@ Perl_ck_tell(pTHX_ OP *o) o = ck_fun(o); if (o->op_flags & OPf_KIDS) { OP *kid = cLISTOPo->op_first; - if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling; + if (kid->op_type == OP_NULL && OP_HAS_SIBLING(kid)) kid = OP_SIBLING(kid); if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; } return o; @@ -10577,39 +10885,39 @@ S_inplace_aassign(pTHX_ OP *o) { assert(cUNOPo->op_first->op_type == OP_NULL); modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first; assert(modop_pushmark->op_type == OP_PUSHMARK); - modop = modop_pushmark->op_sibling; + modop = OP_SIBLING(modop_pushmark); if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE) return; /* no other operation except sort/reverse */ - if (modop->op_sibling) + if (OP_HAS_SIBLING(modop)) return; assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); - if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return; + if (!(oright = OP_SIBLING(cUNOPx(modop)->op_first))) return; if (modop->op_flags & OPf_STACKED) { /* skip sort subroutine/block */ assert(oright->op_type == OP_NULL); - oright = oright->op_sibling; + oright = OP_SIBLING(oright); } - assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL); - oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first; + assert(OP_SIBLING(cUNOPo->op_first)->op_type == OP_NULL); + oleft_pushmark = cUNOPx(OP_SIBLING(cUNOPo->op_first))->op_first; assert(oleft_pushmark->op_type == OP_PUSHMARK); - oleft = oleft_pushmark->op_sibling; + oleft = OP_SIBLING(oleft_pushmark); /* Check the lhs is an array */ if (!oleft || (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV) - || oleft->op_sibling + || OP_HAS_SIBLING(oleft) || (oleft->op_private & OPpLVAL_INTRO) ) return; /* Only one thing on the rhs */ - if (oright->op_sibling) + if (OP_HAS_SIBLING(oright)) return; /* check the array is the same on both sides */ @@ -10745,7 +11053,7 @@ Perl_rpeep(pTHX_ OP *o) OP *sibling; OP *other_pushmark; if (OP_TYPE_IS(o->op_next, OP_PUSHMARK) - && (sibling = o->op_sibling) + && (sibling = OP_SIBLING(o)) && sibling->op_type == OP_LIST /* This KIDS check is likely superfluous since OP_LIST * would otherwise be an OP_STUB. */ @@ -10784,25 +11092,25 @@ Perl_rpeep(pTHX_ OP *o) */ { OP *next = o->op_next; - OP *sibling = o->op_sibling; + OP *sibling = OP_SIBLING(o); if ( OP_TYPE_IS(next, OP_PUSHMARK) && OP_TYPE_IS(sibling, OP_RETURN) && OP_TYPE_IS(sibling->op_next, OP_LINESEQ) && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB) && cUNOPx(sibling)->op_first == next - && next->op_sibling && next->op_sibling->op_next + && OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next && next->op_next ) { /* Look through the PUSHMARK's siblings for one that * points to the RETURN */ - OP *top = next->op_sibling; + OP *top = OP_SIBLING(next); while (top && top->op_next) { if (top->op_next == sibling) { top->op_next = sibling->op_next; o->op_next = next->op_next; break; } - top = top->op_sibling; + top = OP_SIBLING(top); } } } @@ -10837,35 +11145,45 @@ Perl_rpeep(pTHX_ OP *o) && (!CopLABEL((COP*)o)) /* Don't mess with labels */ && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */ ) { - OP *first; - OP *last; - OP *newop; - - first = o->op_next; - last = o->op_next->op_next->op_next; - - newop = newLISTOP(OP_LIST, 0, first, last); + OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm; + + pad1 = o->op_next; + ns2 = pad1->op_next; + pad2 = ns2->op_next; + ns3 = pad2->op_next; + + /* we assume here that the op_next chain is the same as + * the op_sibling chain */ + assert(OP_SIBLING(o) == pad1); + assert(OP_SIBLING(pad1) == ns2); + assert(OP_SIBLING(ns2) == pad2); + assert(OP_SIBLING(pad2) == ns3); + + /* create new listop, with children consisting of: + * a new pushmark, pad1, pad2. */ + OP_SIBLING_set(pad2, NULL); + newop = newLISTOP(OP_LIST, 0, pad1, pad2); newop->op_flags |= OPf_PARENS; newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; + newpm = cUNOPx(newop)->op_first; /* pushmark */ /* Kill nextstate2 between padop1/padop2 */ - op_free(first->op_next); - - first->op_next = last; /* padop2 */ - first->op_sibling = last; /* ... */ - o->op_next = cUNOPx(newop)->op_first; /* pushmark */ - o->op_next->op_next = first; /* padop1 */ - o->op_next->op_sibling = first; /* ... */ - newop->op_next = last->op_next; /* nextstate3 */ - newop->op_sibling = last->op_sibling; - last->op_next = newop; /* listop */ - last->op_sibling = NULL; - o->op_sibling = newop; /* ... */ + op_free(ns2); + + o ->op_next = newpm; + newpm->op_next = pad1; + pad1 ->op_next = pad2; + pad2 ->op_next = newop; /* listop */ + newop->op_next = ns3; + + OP_SIBLING_set(o, newop); + OP_SIBLING_set(newop, ns3); + newop->op_lastsib = 0; newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; /* Ensure pushmark has this flag if padops do */ - if (first->op_flags & OPf_MOD && last->op_flags & OPf_MOD) { + if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) { o->op_next->op_flags |= OPf_MOD; } @@ -11015,7 +11333,7 @@ Perl_rpeep(pTHX_ OP *o) && !(rv2av->op_flags & OPf_REF) && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB)) && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST) - && o->op_sibling == rv2av /* these two for Deparse */ + && OP_SIBLING(o) == rv2av /* these two for Deparse */ && cUNOPx(rv2av)->op_first == p ) { q = rv2av->op_next; @@ -11030,8 +11348,8 @@ Perl_rpeep(pTHX_ OP *o) if (!defav) { /* To allow Deparse to pessimise this, it needs to be able * to restore the pushmark's original op_next, which it - * will assume to be the same as op_sibling. */ - if (o->op_next != o->op_sibling) + * will assume to be the same as OP_SIBLING. */ + if (o->op_next != OP_SIBLING(o)) break; p = o; } @@ -11291,7 +11609,7 @@ Perl_rpeep(pTHX_ OP *o) case OP_OR: case OP_DOR: fop = cLOGOP->op_first; - sop = fop->op_sibling; + sop = OP_SIBLING(fop); while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; while (o->op_next && ( o->op_type == o->op_next->op_type @@ -11405,7 +11723,7 @@ Perl_rpeep(pTHX_ OP *o) if (o->op_flags & OPf_SPECIAL) { /* first arg is a code block */ - OP * const nullop = cLISTOP->op_first->op_sibling; + OP * const nullop = OP_SIBLING(cLISTOP->op_first); OP * kid = cUNOPx(nullop)->op_first; assert(nullop->op_type == OP_NULL); @@ -11436,7 +11754,7 @@ Perl_rpeep(pTHX_ OP *o) break; /* reverse sort ... can be optimised. */ - if (!cUNOPo->op_sibling) { + if (!OP_HAS_SIBLING(cUNOPo)) { /* Nothing follows us on the list. */ OP * const reverse = o->op_next; @@ -11444,7 +11762,7 @@ Perl_rpeep(pTHX_ OP *o) (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) { OP * const pushmark = cUNOPx(reverse)->op_first; if (pushmark && (pushmark->op_type == OP_PUSHMARK) - && (cUNOPx(pushmark)->op_sibling == o)) { + && (OP_SIBLING(cUNOPx(pushmark)) == o)) { /* reverse -> pushmark -> sort */ o->op_private |= OPpSORT_REVERSE; op_null(reverse); @@ -11499,7 +11817,7 @@ Perl_rpeep(pTHX_ OP *o) || expushmark->op_targ != OP_PUSHMARK) break; - exlist = (LISTOP *) expushmark->op_sibling; + exlist = (LISTOP *) OP_SIBLING(expushmark); if (!exlist || exlist->op_type != OP_NULL || exlist->op_targ != OP_LIST) break; @@ -11512,7 +11830,7 @@ Perl_rpeep(pTHX_ OP *o) if (!theirmark || theirmark->op_type != OP_PUSHMARK) break; - if (theirmark->op_sibling != o) { + if (OP_SIBLING(theirmark) != o) { /* There's something between the mark and the reverse, eg for (1, reverse (...)) so no go. */ @@ -11527,8 +11845,8 @@ Perl_rpeep(pTHX_ OP *o) if (!ourlast || ourlast->op_next != o) break; - rv2av = ourmark->op_sibling; - if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0 + rv2av = OP_SIBLING(ourmark); + if (rv2av && rv2av->op_type == OP_RV2AV && !OP_HAS_SIBLING(rv2av) && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS) && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) { /* We're just reversing a single array. */ @@ -11593,14 +11911,15 @@ Perl_rpeep(pTHX_ OP *o) * arg2 * ... */ - OP *left = right->op_sibling; + OP *left = OP_SIBLING(right); if (left->op_type == OP_SUBSTR && (left->op_private & 7) < 4) { op_null(o); - cBINOP->op_first = left; - right->op_sibling = - cBINOPx(left)->op_first->op_sibling; - cBINOPx(left)->op_first->op_sibling = right; + /* cut out right */ + op_sibling_splice(o, NULL, 1, NULL); + /* and insert it as second child of OP_SUBSTR */ + op_sibling_splice(left, cBINOPx(left)->op_first, 0, + right); left->op_private |= OPpSUBSTR_REPL_FIRST; left->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; @@ -12079,7 +12398,6 @@ Perl_wrap_op_checker(pTHX_ Optype opcode, static void const_sv_xsub(pTHX_ CV* cv) { - dVAR; dXSARGS; SV *const sv = MUTABLE_SV(XSANY.any_ptr); PERL_UNUSED_ARG(items); @@ -12094,7 +12412,6 @@ const_sv_xsub(pTHX_ CV* cv) static void const_av_xsub(pTHX_ CV* cv) { - dVAR; dXSARGS; AV * const av = MUTABLE_AV(XSANY.any_ptr); SP -= items; diff --git a/op.h b/op.h index 100514c..9f94caf 100644 --- a/op.h +++ b/op.h @@ -24,7 +24,8 @@ * !op_slabbed. * op_savefree on savestack via SAVEFREEOP * op_folded Result/remainder of a constant fold operation. - * op_spare Two spare bits + * op_lastsib this op is is the last sibling + * op_spare One spare bit * op_flags Flags common to all operations. See OPf_* below. * op_private Flags peculiar to a particular operation (BUT, * by default, set to the number of children until @@ -51,7 +52,8 @@ typedef PERL_BITFIELD16 Optype; PERL_BITFIELD16 op_savefree:1; \ PERL_BITFIELD16 op_static:1; \ PERL_BITFIELD16 op_folded:1; \ - PERL_BITFIELD16 op_spare:2; \ + PERL_BITFIELD16 op_lastsib:1; \ + PERL_BITFIELD16 op_spare:1; \ U8 op_flags; \ U8 op_private; #endif @@ -1016,6 +1018,15 @@ is also available as well as C and C which elide the NULL pointer check. +=for apidoc Am|bool|OP_HAS_SIBLING|OP *o +Returns true if o has a sibling + +=for apidoc Am|bool|OP_SIBLING|OP *o +Returns the sibling of o, or NULL if there is no sibling + +=for apidoc Am|bool|OP_SIBLING_set|OP *o|OP *sib +Sets the sibling of o to sib + =cut */ @@ -1052,6 +1063,16 @@ the NULL pointer check. #define OP_TYPE_ISNT_AND_WASNT(o, type) \ ( (o) && OP_TYPE_ISNT_AND_WASNT_NN(o, type) ) +#ifdef PERL_OP_PARENT +# define OP_HAS_SIBLING(o) (!cBOOL((o)->op_lastsib)) +# define OP_SIBLING(o) (0 + (o)->op_lastsib ? NULL : (o)->op_sibling) +# define OP_SIBLING_set(o, sib) ((o)->op_sibling = (sib)) +#else +# define OP_HAS_SIBLING(o) (cBOOL((o)->op_sibling)) +# define OP_SIBLING(o) (0 + (o)->op_sibling) +# define OP_SIBLING_set(o, sib) ((o)->op_sibling = (sib)) +#endif + #define newATTRSUB(f, o, p, a, b) Perl_newATTRSUB_x(aTHX_ f, o, p, a, b, FALSE) #define newSUB(f, o, p, b) newATTRSUB((f), (o), (p), NULL, (b)) diff --git a/pad.c b/pad.c index da067bf..18b6e5c 100644 --- a/pad.c +++ b/pad.c @@ -210,7 +210,6 @@ flags can be OR'ed together: PADLIST * Perl_pad_new(pTHX_ int flags) { - dVAR; PADLIST *padlist; PAD *padname, *pad; PAD **ary; @@ -317,7 +316,6 @@ children can still follow the full lexical scope chain. void Perl_cv_undef(pTHX_ CV *cv) { - dVAR; const PADLIST *padlist = CvPADLIST(cv); bool const slabbed = !!CvSLABBED(cv); @@ -532,7 +530,6 @@ is done. Returns the offset of the allocated pad slot. static PADOFFSET S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash) { - dVAR; const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); PERL_ARGS_ASSERT_PAD_ALLOC_NAME; @@ -583,7 +580,6 @@ PADOFFSET Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags, HV *typestash, HV *ourstash) { - dVAR; PADOFFSET offset; SV *namesv; bool is_utf8; @@ -715,7 +711,6 @@ but is used for debugging. PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) { - dVAR; SV *sv; I32 retval; @@ -795,7 +790,6 @@ but is used for debugging. PADOFFSET Perl_pad_add_anon(pTHX_ CV* func, I32 optype) { - dVAR; PADOFFSET ix; SV* const name = newSV_type(SVt_PVNV); @@ -847,7 +841,6 @@ C indicates that the name to check is an 'our' declaration. STATIC void S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash) { - dVAR; SV **svp; PADOFFSET top, off; const U32 is_our = flags & padadd_OUR; @@ -932,7 +925,6 @@ or C if no such lexical is in scope. PADOFFSET Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) { - dVAR; SV *out_sv; int out_flags; I32 offset; @@ -1034,7 +1026,6 @@ L is likely to be more convenient. PADOFFSET Perl_find_rundefsvoffset(pTHX) { - dVAR; SV *out_sv; int out_flags; return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1, @@ -1132,7 +1123,6 @@ STATIC PADOFFSET S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq, int warn, SV** out_capture, SV** out_name_sv, int *out_flags) { - dVAR; I32 offset, new_offset; SV *new_capture; SV **new_capturep; @@ -1468,7 +1458,6 @@ Update the pad compilation state variables on entry to a new block. void Perl_pad_block_start(pTHX_ int full) { - dVAR; ASSERT_CURPAD_ACTIVE("pad_block_start"); SAVEI32(PL_comppad_name_floor); PL_comppad_name_floor = AvFILLp(PL_comppad_name); @@ -1498,7 +1487,6 @@ subsequent statements. U32 Perl_intro_my(pTHX) { - dVAR; SV **svp; I32 i; U32 seq; @@ -1548,7 +1536,6 @@ lexicals in this scope and warn of any lexicals that never got introduced. OP * Perl_pad_leavemy(pTHX) { - dVAR; I32 off; OP *o = NULL; SV * const * const svp = AvARRAY(PL_comppad_name); @@ -1606,7 +1593,6 @@ new one. void Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) { - dVAR; ASSERT_CURPAD_LEGAL("pad_swipe"); if (!PL_curpad) return; @@ -1661,7 +1647,6 @@ Mark all the current temporaries for reuse static void S_pad_reset(pTHX) { - dVAR; #ifdef USE_BROKEN_PAD_RESET if (AvARRAY(PL_comppad) != PL_curpad) Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p", @@ -1826,7 +1811,6 @@ Free the SV at offset po in the current pad. void Perl_pad_free(pTHX_ PADOFFSET po) { - dVAR; SV *sv; ASSERT_CURPAD_LEGAL("pad_free"); if (!PL_curpad) @@ -1862,7 +1846,6 @@ Dump the contents of a padlist void Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) { - dVAR; const AV *pad_name; const AV *pad; SV **pname; @@ -1981,7 +1964,6 @@ static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside); static void S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) { - dVAR; I32 ix; PADLIST* const protopadlist = CvPADLIST(proto); PAD *const protopad_name = *PadlistARRAY(protopadlist); @@ -2136,7 +2118,9 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) static CV * S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside) { +#ifdef USE_ITHREADS dVAR; +#endif const bool newcv = !cv; assert(!CvUNIQUE(proto)); @@ -2228,7 +2212,6 @@ moved to a pre-existing CV struct. void Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) { - dVAR; I32 ix; AV * const comppad_name = PadlistARRAY(padlist)[0]; AV * const comppad = PadlistARRAY(padlist)[1]; @@ -2285,8 +2268,6 @@ the new pad an @_ in slot zero. void Perl_pad_push(pTHX_ PADLIST *padlist, int depth) { - dVAR; - PERL_ARGS_ASSERT_PAD_PUSH; if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) { @@ -2351,10 +2332,9 @@ class to which it is typed is returned. If not, C is returned. HV * Perl_pad_compname_type(pTHX_ const PADOFFSET po) { - dVAR; - SV* const * const av = av_fetch(PL_comppad_name, po, FALSE); - if ( SvPAD_TYPED(*av) ) { - return SvSTASH(*av); + SV* const av = PAD_COMPNAME_SV(po); + if ( SvPAD_TYPED(av) ) { + return SvSTASH(av); } return NULL; } @@ -2493,7 +2473,6 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) PAD ** Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val) { - dVAR; PAD **ary; SSize_t const oldmax = PadlistMAX(padlist); diff --git a/pad.h b/pad.h index b36eafb..c29a13f 100644 --- a/pad.h +++ b/pad.h @@ -398,7 +398,7 @@ ling pad (lvalue) to C. Note that C is hijacked for this purpose */ #define PAD_COMPNAME(po) PAD_COMPNAME_SV(po) -#define PAD_COMPNAME_SV(po) (*av_fetch(PL_comppad_name, (po), FALSE)) +#define PAD_COMPNAME_SV(po) (AvARRAY(PL_comppad_name)[(po)]) #define PAD_COMPNAME_FLAGS(po) SvFLAGS(PAD_COMPNAME_SV(po)) #define PAD_COMPNAME_FLAGS_isOUR(po) SvPAD_OUR(PAD_COMPNAME_SV(po)) #define PAD_COMPNAME_PV(po) SvPV_nolen(PAD_COMPNAME_SV(po)) diff --git a/patchlevel.h b/patchlevel.h index 3101f08..30673d1 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -15,7 +15,7 @@ #define PERL_REVISION 5 /* age */ #define PERL_VERSION 21 /* epoch */ -#define PERL_SUBVERSION 1 /* generation */ +#define PERL_SUBVERSION 2 /* 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 21 -#define PERL_API_SUBVERSION 1 +#define PERL_API_SUBVERSION 2 /* 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 9e0d2b5..6e09931 100644 --- a/perl.c +++ b/perl.c @@ -1415,7 +1415,6 @@ perl_fini(void) void Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) { - dVAR; Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry); PL_exitlist[PL_exitlistlen].fn = fn; PL_exitlist[PL_exitlistlen].ptr = ptr; @@ -2308,7 +2307,6 @@ Tells a Perl interpreter to run. See L. int perl_run(pTHXx) { - dVAR; I32 oldscope; int ret = 0; dJMPENV; @@ -2366,7 +2364,6 @@ perl_run(pTHXx) STATIC void S_run_body(pTHX_ I32 oldscope) { - dVAR; DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support (0x%x).\n", PL_sawampersand ? "Enabling" : "Omitting", (unsigned int)(PL_sawampersand))); @@ -2566,7 +2563,6 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv) /* See G_* flags in cop.h */ /* null terminated arg list */ { - dVAR; dSP; PERL_ARGS_ASSERT_CALL_ARGV; @@ -2888,7 +2884,6 @@ Tells Perl to C the given string and return an SV* result. SV* Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) { - dVAR; SV* sv = newSVpv(p, 0); PERL_ARGS_ASSERT_EVAL_PV; @@ -2929,7 +2924,6 @@ implemented that way; consider using load_module instead. void Perl_require_pv(pTHX_ const char *pv) { - dVAR; dSP; SV* sv; @@ -3531,7 +3525,6 @@ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); void Perl_my_unexec(pTHX) { - PERL_UNUSED_CONTEXT; #ifdef UNEXEC SV * prog = newSVpv(BIN_EXP, 0); SV * file = newSVpv(PL_origfilename, 0); @@ -3545,10 +3538,11 @@ Perl_my_unexec(pTHX) /* unexec prints msg to stderr in case of failure */ PerlProc_exit(status); #else + PERL_UNUSED_CONTEXT; # ifdef VMS lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */ # elif defined(WIN32) || defined(__CYGWIN__) - Perl_croak(aTHX_ "dump is not supported"); + Perl_croak_nocontext("dump is not supported"); # else ABORT(); /* for use with undump */ # endif @@ -3559,7 +3553,6 @@ Perl_my_unexec(pTHX) STATIC void S_init_interp(pTHX) { - dVAR; #ifdef MULTIPLICITY # define PERLVAR(prefix,var,type) # define PERLVARA(prefix,var,n,type) @@ -3592,7 +3585,6 @@ S_init_interp(pTHX) STATIC void S_init_main_stash(pTHX) { - dVAR; GV *gv; PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV()); @@ -3644,7 +3636,6 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) { int fdscript = -1; PerlIO *rsfp = NULL; - dVAR; Stat_t tmpstatbuf; int fd; @@ -3821,7 +3812,6 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); STATIC void S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) { - dVAR; const char *s; const char *s2; @@ -3854,12 +3844,13 @@ S_init_ids(pTHX) /* no need to do anything here any more if we don't * do tainting. */ #ifndef NO_TAINT_SUPPORT - dVAR; const Uid_t my_uid = PerlProc_getuid(); const Uid_t my_euid = PerlProc_geteuid(); const Gid_t my_gid = PerlProc_getgid(); const Gid_t my_egid = PerlProc_getegid(); + PERL_UNUSED_CONTEXT; + /* Should not happen: */ CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid)); TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) ); @@ -3919,10 +3910,10 @@ Perl_doing_taint(int argc, char *argv[], char *envp[]) STATIC void S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */ { - dVAR; char string[3] = "-x"; const char *message = "program input from stdin"; + PERL_UNUSED_CONTEXT; if (flag) { string[1] = flag; message = string; @@ -3959,7 +3950,6 @@ Perl_init_dbargs(pTHX) void Perl_init_debugger(pTHX) { - dVAR; HV * const ostash = PL_curstash; PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash); @@ -3998,7 +3988,6 @@ Perl_init_debugger(pTHX) void Perl_init_stacks(pTHX) { - dVAR; /* start with 128-item stack and 8K cxstack */ PL_curstackinfo = new_stackinfo(REASONABLE(128), REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); @@ -4038,7 +4027,6 @@ Perl_init_stacks(pTHX) STATIC void S_nuke_stacks(pTHX) { - dVAR; while (PL_curstackinfo->si_next) PL_curstackinfo = PL_curstackinfo->si_next; while (PL_curstackinfo) { @@ -4094,7 +4082,6 @@ Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...) STATIC void S_init_predump_symbols(pTHX) { - dVAR; GV *tmpgv; IO *io; @@ -4155,8 +4142,6 @@ S_init_predump_symbols(pTHX) void Perl_init_argv_symbols(pTHX_ int argc, char **argv) { - dVAR; - PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS; argc--,argv++; /* skip name of script */ @@ -4203,7 +4188,9 @@ Perl_init_argv_symbols(pTHX_ int argc, char **argv) STATIC void S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) { +#ifdef USE_ITHREADS dVAR; +#endif GV* tmpgv; PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS; @@ -4280,7 +4267,6 @@ S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) STATIC void S_init_perllib(pTHX) { - dVAR; #ifndef VMS const char *perl5lib = NULL; #endif @@ -4486,7 +4472,6 @@ S_init_perllib(pTHX) STATIC SV * S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem) { - dVAR; Stat_t tmpstatbuf; PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS; @@ -4641,7 +4626,6 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) STATIC void S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) { - dVAR; #ifndef PERL_IS_MINIPERL const U8 using_sub_dirs = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS @@ -4800,7 +4784,6 @@ S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags) void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { - dVAR; SV *atsv; volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0; CV *cv; @@ -4883,7 +4866,6 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) void Perl_my_exit(pTHX_ U32 status) { - dVAR; if (PL_exit_flags & PERL_EXIT_ABORT) { abort(); } @@ -4909,7 +4891,6 @@ Perl_my_exit(pTHX_ U32 status) void Perl_my_failure_exit(pTHX) { - dVAR; #ifdef VMS /* We have been called to fall on our sword. The desired exit code * should be already set in STATUS_UNIX, but could be shifted over @@ -5003,8 +4984,6 @@ Perl_my_failure_exit(pTHX) STATIC void S_my_exit_jump(pTHX) { - dVAR; - if (PL_e_script) { SvREFCNT_dec(PL_e_script); PL_e_script = NULL; @@ -5020,7 +4999,6 @@ S_my_exit_jump(pTHX) static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) { - dVAR; const char * const p = SvPVX_const(PL_e_script); const char *nl = strchr(p, '\n'); diff --git a/perl.h b/perl.h index 58dd2c1..54f6dca 100644 --- a/perl.h +++ b/perl.h @@ -321,7 +321,7 @@ # define PERL_UNUSED_VAR(x) ((void)x) #endif -#ifdef USE_ITHREADS +#if defined(USE_ITHREADS) || defined(PERL_GLOBAL_STRUCT) # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) #else # define PERL_UNUSED_CONTEXT @@ -391,12 +391,8 @@ * semicolon being left alone on a line: * ; * which makes compilers mildly cranky. Therefore at file level one - * should use the #ifdef GCC_DIAG_PRAGMA guard around the GCC_DIAG_IGNORE - * and GCC_DIAG_RESTORE. - * - * (An alternative solution would be not to use the semicolon, and then - * the empty definition would be just empty, but that would make the code - * look odd, and might mess up e.g. smart editors indenting the code.) + * should use the GCC_DIAG_IGNORE and GCC_DIAG_RESTORE_FILE *without* + * the semicolons. * * (A dead-on-arrival solution would be to try to define the macros as * NOOP or dNOOP, those don't work both inside functions and outside.) @@ -738,6 +734,9 @@ # if !defined(NO_LOCALE_MONETARY) && defined(LC_MONETARY) # define USE_LOCALE_MONETARY # endif +# if !defined(NO_LOCALE_TIME) && defined(LC_TIME) +# define USE_LOCALE_TIME +# endif # ifndef WIN32 /* No wrapper except on Windows */ # define my_setlocale(a,b) setlocale(a,b) # endif @@ -1545,12 +1544,14 @@ EXTERN_C char *crypt(const char *, const char *); * that should be true only if the snprintf()/vsnprintf() are true * to the standard. */ +#define PERL_SNPRINTF_CHECK(len, max, api) STMT_START { if ((max) > 0 && (Size_t)len >= (max)) Perl_croak_nocontext("panic: %s buffer overflow", STRINGIFY(api)); } STMT_END + #if defined(HAS_SNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC) # ifdef PERL_USE_GCC_BRACE_GROUPS -# define my_snprintf(buffer, len, ...) ({ int __len__ = snprintf(buffer, len, __VA_ARGS__); if ((len) > 0 && (Size_t)__len__ >= (len)) Perl_croak_nocontext("panic: snprintf buffer overflow"); __len__; }) +# define my_snprintf(buffer, max, ...) ({ int len = snprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, snprintf); len; }) # define PERL_MY_SNPRINTF_GUARDED # else -# define my_snprintf(buffer, len, ...) snprintf(buffer, len, __VA_ARGS__) +# define my_snprintf(buffer, max, ...) snprintf(buffer, max, __VA_ARGS__) # endif #else # define my_snprintf Perl_my_snprintf @@ -1559,16 +1560,47 @@ EXTERN_C char *crypt(const char *, const char *); #if defined(HAS_VSNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC) # ifdef PERL_USE_GCC_BRACE_GROUPS -# define my_vsnprintf(buffer, len, ...) ({ int __len__ = vsnprintf(buffer, len, __VA_ARGS__); if ((len) > 0 && (Size_t)__len__ >= (Size_t)(len)) Perl_croak_nocontext("panic: vsnprintf buffer overflow"); __len__; }) +# define my_vsnprintf(buffer, max, ...) ({ int len = vsnprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, vsnprintf); len; }) # define PERL_MY_VSNPRINTF_GUARDED # else -# define my_vsnprintf(buffer, len, ...) vsnprintf(buffer, len, __VA_ARGS__) +# define my_vsnprintf(buffer, max, ...) vsnprintf(buffer, max, __VA_ARGS__) # endif #else # define my_vsnprintf Perl_my_vsnprintf # define PERL_MY_VSNPRINTF_GUARDED #endif +/* You will definitely need to use the PERL_MY_SNPRINTF_POST_GUARD() + * or PERL_MY_VSNPRINTF_POST_GUARD() if you otherwise decide to ignore + * the result of my_snprintf() or my_vsnprintf(). (No, you should not + * completely ignore it: otherwise you cannot know whether your output + * was too long.) + * + * int len = my_sprintf(buf, max, ...); + * PERL_MY_SNPRINTF_POST_GUARD(len, max); + * + * The trick is that in certain platforms [a] the my_sprintf() already + * contains the sanity check, while in certain platforms [b] it needs + * to be done as a separate step. The POST_GUARD is that step-- in [a] + * platforms the POST_GUARD actually does nothing since the check has + * already been done. Watch out for the max being the same in both calls. + * + * If you actually use the snprintf/vsnprintf return value already, + * you assumedly are checking its validity somehow. But you can + * insert the POST_GUARD() also in that case. */ + +#ifndef PERL_MY_SNPRINTF_GUARDED +# define PERL_MY_SNPRINTF_POST_GUARD(len, max) PERL_SNPRINTF_CHECK(len, max, snprintf) +#else +# define PERL_MY_SNPRINTF_POST_GUARD(len, max) PERL_UNUSED_VAR(len) +#endif + +#ifndef PERL_MY_VSNPRINTF_GUARDED +# define PERL_MY_VSNPRINTF_POST_GUARD(len, max) PERL_SNPRINTF_CHECK(len, max, vsnprintf) +#else +# define PERL_MY_VSNPRINTF_POST_GUARD(len, max) PERL_UNUSED_VAR(len) +#endif + #ifdef HAS_STRLCAT # define my_strlcat strlcat #else @@ -4661,6 +4693,9 @@ EXTCONST char PL_bincompat_options[] = # ifdef USE_LOCALE_NUMERIC " USE_LOCALE_NUMERIC" # endif +# ifdef USE_LOCALE_TIME + " USE_LOCALE_TIME" +# endif # ifdef USE_LONG_DOUBLE " USE_LONG_DOUBLE" # endif @@ -5729,6 +5764,7 @@ int flock(int fd, int op); #define IS_NUMBER_NEG 0x08 /* leading minus sign */ #define IS_NUMBER_INFINITY 0x10 /* this is big */ #define IS_NUMBER_NAN 0x20 /* this is not */ +#define IS_NUMBER_TRAILING 0x40 /* number has trailing trash */ #define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) @@ -5738,6 +5774,9 @@ int flock(int fd, int op); #define PERL_SCAN_SILENT_ILLDIGIT 0x04 /* grok_??? not warn about illegal digits */ #define PERL_SCAN_SILENT_NON_PORTABLE 0x08 /* grok_??? not warn about very large numbers which are <= UV_MAX */ +#define PERL_SCAN_TRAILING 0x10 /* grok_number_flags() allow trailing + and set IS_NUMBER_TRAILING */ + /* Output flags: */ #define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 /* should this merge with above? */ diff --git a/perlio.c b/perlio.c index 7de32f4..6c742d2 100644 --- a/perlio.c +++ b/perlio.c @@ -466,7 +466,6 @@ PerlIO_init_table(pTHX) PerlIO * PerlIO_allocate(pTHX) { - dVAR; /* * Find a free slot in the table, allocating new table as necessary */ @@ -563,7 +562,6 @@ PerlIO_list_free(pTHX_ PerlIO_list_t *list) void PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg) { - dVAR; PerlIO_pair_t *p; PERL_UNUSED_CONTEXT; @@ -633,7 +631,6 @@ PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param) void PerlIO_destruct(pTHX) { - dVAR; PerlIOl **table = &PL_perlio; PerlIOl *f; #ifdef USE_ITHREADS @@ -699,7 +696,6 @@ PerlIO_pop(pTHX_ PerlIO *f) AV * PerlIO_get_layers(pTHX_ PerlIO *f) { - dVAR; AV * const av = newAV(); if (PerlIOValid(f)) { @@ -733,7 +729,7 @@ PerlIO_get_layers(pTHX_ PerlIO *f) PerlIO_funcs * PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) { - dVAR; + IV i; if ((SSize_t) len <= 0) len = strlen(name); @@ -870,7 +866,6 @@ XS(XS_PerlIO__Layer__NoWarnings) /* This is used as a %SIG{__WARN__} handler to suppress warnings during loading of layers. */ - dVAR; dXSARGS; PERL_UNUSED_ARG(cv); if (items) @@ -881,7 +876,6 @@ XS(XS_PerlIO__Layer__NoWarnings) XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */ XS(XS_PerlIO__Layer__find) { - dVAR; dXSARGS; PERL_UNUSED_ARG(cv); if (items < 2) @@ -901,7 +895,6 @@ XS(XS_PerlIO__Layer__find) void PerlIO_define_layer(pTHX_ PerlIO_funcs *tab) { - dVAR; if (!PL_known_layers) PL_known_layers = PerlIO_list_alloc(aTHX); PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL); @@ -911,7 +904,6 @@ PerlIO_define_layer(pTHX_ PerlIO_funcs *tab) int PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) { - dVAR; if (names) { const char *s = names; while (*s) { @@ -1004,7 +996,6 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) void PerlIO_default_buffer(pTHX_ PerlIO_list_t *av) { - dVAR; PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio; #ifdef PERLIO_USING_CRLF tab = &PerlIO_crlf; @@ -1084,7 +1075,6 @@ PERLIO_FUNCS_DECL(PerlIO_remove) = { PerlIO_list_t * PerlIO_default_layers(pTHX) { - dVAR; if (!PL_def_layerlist) { const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO"); PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix; @@ -1133,7 +1123,6 @@ Perl_boot_core_PerlIO(pTHX) PerlIO_funcs * PerlIO_default_layer(pTHX_ I32 n) { - dVAR; PerlIO_list_t * const av = PerlIO_default_layers(aTHX); if (n < 0) n += av->cur; @@ -1146,7 +1135,6 @@ PerlIO_default_layer(pTHX_ I32 n) void PerlIO_stdstreams(pTHX) { - dVAR; if (!PL_perlio) { PerlIO_init_table(aTHX); PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT); @@ -1420,15 +1408,13 @@ Perl_PerlIO_close(pTHX_ PerlIO *f) int Perl_PerlIO_fileno(pTHX_ PerlIO *f) { - dVAR; - Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f)); + Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f)); } static PerlIO_funcs * PerlIO_layer_from_ref(pTHX_ SV *sv) { - dVAR; /* * For any scalar type load the handler which is bundled with perl */ @@ -1463,7 +1449,6 @@ PerlIO_list_t * PerlIO_resolve_layers(pTHX_ const char *layers, const char *mode, int narg, SV **args) { - dVAR; PerlIO_list_t *def = PerlIO_default_layers(aTHX); int incdef = 1; if (!PL_perlio) @@ -1517,7 +1502,6 @@ PerlIO * PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) { - dVAR; if (!f && narg == 1 && *args == &PL_sv_undef) { if ((f = PerlIO_tmpfile())) { if (!layers || !*layers) @@ -1641,7 +1625,6 @@ Perl_PerlIO_tell(pTHX_ PerlIO *f) int Perl_PerlIO_flush(pTHX_ PerlIO *f) { - dVAR; if (f) { if (*f) { const PerlIO_funcs *tab = PerlIOBase(f)->tab; @@ -1684,7 +1667,6 @@ Perl_PerlIO_flush(pTHX_ PerlIO *f) void PerlIOBase_flush_linebuf(pTHX) { - dVAR; PerlIOl **table = &PL_perlio; PerlIOl *f; while ((f = *table)) { @@ -2391,7 +2373,6 @@ PerlIOUnix_refcnt(int fd) void PerlIO_cleanup(pTHX) { - dVAR; int i; #ifdef USE_ITHREADS PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX); @@ -2735,7 +2716,6 @@ PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) SSize_t PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { - dVAR; int fd; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ return -1; @@ -2772,7 +2752,6 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) SSize_t PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { - dVAR; int fd; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ return -1; @@ -2810,7 +2789,6 @@ PerlIOUnix_tell(pTHX_ PerlIO *f) IV PerlIOUnix_close(pTHX_ PerlIO *f) { - dVAR; const int fd = PerlIOSelf(f, PerlIOUnix)->fd; int code = 0; if (PerlIOBase(f)->flags & PERLIO_F_OPEN) { @@ -3316,7 +3294,6 @@ PerlIOStdio_close(pTHX_ PerlIO *f) SSize_t PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { - dVAR; FILE * s; SSize_t got = 0; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ @@ -3409,7 +3386,6 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) SSize_t PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { - dVAR; SSize_t got; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ return -1; @@ -3776,7 +3752,6 @@ PerlIO_findFILE(PerlIO *f) void PerlIO_releaseFILE(PerlIO *p, FILE *f) { - dVAR; PerlIOl *l; while ((l = *p)) { if (l->tab == &PerlIO_stdio) { @@ -4808,7 +4783,6 @@ PERLIO_FUNCS_DECL(PerlIO_crlf) = { PerlIO * Perl_PerlIO_stdin(pTHX) { - dVAR; if (!PL_perlio) { PerlIO_stdstreams(aTHX); } @@ -4818,7 +4792,6 @@ Perl_PerlIO_stdin(pTHX) PerlIO * Perl_PerlIO_stdout(pTHX) { - dVAR; if (!PL_perlio) { PerlIO_stdstreams(aTHX); } @@ -4828,7 +4801,6 @@ Perl_PerlIO_stdout(pTHX) PerlIO * Perl_PerlIO_stderr(pTHX) { - dVAR; if (!PL_perlio) { PerlIO_stdstreams(aTHX); } @@ -5066,7 +5038,6 @@ PerlIO_tmpfile(void) const char * Perl_PerlIO_context_layers(pTHX_ const char *mode) { - dVAR; const char *direction = NULL; SV *layers; /* diff --git a/perly.c b/perly.c index eb25893..034a1a7 100644 --- a/perly.c +++ b/perly.c @@ -236,7 +236,6 @@ S_clear_yystack(pTHX_ const yy_parser *parser) int Perl_yyparse (pTHX_ int gramtype) { - dVAR; int yystate; int yyn; int yyresult; diff --git a/plan9/config.plan9 b/plan9/config.plan9 index 13b7401..7437e4b 100644 --- a/plan9/config.plan9 +++ b/plan9/config.plan9 @@ -3373,8 +3373,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.21.1" /**/ -#define PRIVLIB_EXP "/sys/lib/perl/5.21.1" /**/ +#define PRIVLIB "/sys/lib/perl/5.21.2" /**/ +#define PRIVLIB_EXP "/sys/lib/perl/5.21.2" /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor @@ -3501,9 +3501,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.21.1/site_perl" /**/ -#define SITELIB_EXP "/sys/lib/perl/5.21.1/site_perl" /**/ -#define SITELIB_STEM "/sys/lib/perl/5.21.1/site_perl" /**/ +#define SITELIB "/sys/lib/perl/5.21.2/site_perl" /**/ +#define SITELIB_EXP "/sys/lib/perl/5.21.2/site_perl" /**/ +#define SITELIB_STEM "/sys/lib/perl/5.21.2/site_perl" /**/ /* Size_t_size: * This symbol holds the size of a Size_t in bytes. diff --git a/plan9/config_sh.sample b/plan9/config_sh.sample index a80d1fb..9608ceb 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='1' +api_subversion='2' api_version='21' -api_versionstring='5.21.1' +api_versionstring='5.21.2' ar='ar' -archlib='/sys/lib/perl5/5.21.1/386' -archlibexp='/sys/lib/perl5/5.21.1/386' +archlib='/sys/lib/perl5/5.21.2/386' +archlibexp='/sys/lib/perl5/5.21.2/386' archname64='' archname='386' archobjs='' @@ -729,17 +729,17 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='/sys/lib/perl/5.21.1/386' +installarchlib='/sys/lib/perl/5.21.2/386' installbin='/usr/bin' installman1dir='/sys/man/1pub' installman3dir='/sys/man/2pub' installprefix='/usr' installprefixexp='/usr' -installprivlib='/sys/lib/perl/5.21.1' +installprivlib='/sys/lib/perl/5.21.2' installscript='/usr/bin' -installsitearch='/sys/lib/perl/5.21.1/site_perl/386' +installsitearch='/sys/lib/perl/5.21.2/site_perl/386' installsitebin='/usr/bin' -installsitelib='/sys/lib/perl/5.21.1/site_perl' +installsitelib='/sys/lib/perl/5.21.2/site_perl' installstyle='lib/perl5' installusrbinperl='undef' installvendorarch='' @@ -859,8 +859,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/sys/lib/perl/5.21.1' -privlibexp='/sys/lib/perl/5.21.1' +privlib='/sys/lib/perl/5.21.2' +privlibexp='/sys/lib/perl/5.21.2' procselfexe='' prototype='define' ptrsize='4' @@ -925,13 +925,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.21.1/site_perl/386' +sitearch='/sys/lib/perl/5.21.2/site_perl/386' sitearchexp='/sys/lib/perl/site_perl/386' sitebin='/usr/bin' sitebinexp='/usr/bin' -sitelib='/sys/lib/perl/5.21.1/site_perl' -sitelib_stem='/sys/lib/perl/5.21.1/site_perl' -sitelibexp='/sys/lib/perl/5.21.1/site_perl' +sitelib='/sys/lib/perl/5.21.2/site_perl' +sitelib_stem='/sys/lib/perl/5.21.2/site_perl' +sitelibexp='/sys/lib/perl/5.21.2/site_perl' siteprefix='/usr' siteprefixexp='/usr' sizesize='4' @@ -964,7 +964,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/sys/include/ape/string.h' submit='' -subversion='1' +subversion='2' sysman='/sys/man/1pub' tail='' tar='' @@ -1045,8 +1045,8 @@ vendorlib_stem='' vendorlibexp='' vendorprefix='' vendorprefixexp='' -version='5.21.1' -version_patchlevel_string='version 21 subversion 1' +version='5.21.2' +version_patchlevel_string='version 21 subversion 2' versiononly='undef' vi='' xlibpth='' @@ -1060,9 +1060,9 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=21 -PERL_SUBVERSION=1 +PERL_SUBVERSION=2 PERL_API_REVISION=5 PERL_API_VERSION=21 -PERL_API_SUBVERSION=1 +PERL_API_SUBVERSION=2 PERL_PATCHLEVEL= PERL_CONFIG_SH=true diff --git a/pod/.gitignore b/pod/.gitignore index 4b257ad..5e940fb 100644 --- a/pod/.gitignore +++ b/pod/.gitignore @@ -2,14 +2,11 @@ /perlaix.pod /perlamiga.pod /perlandroid.pod -/perlbeos.pod /perlbs2000.pod /perlce.pod /perlcn.pod /perlcygwin.pod -/perldgux.pod /perldos.pod -/perlepoc.pod /perlfreebsd.pod /perlhaiku.pod /perlhpux.pod @@ -21,7 +18,6 @@ /perlmacos.pod /perlmacosx.pod /perlmodlib.pod -/perlmpeix.pod /perlnetware.pod /perlopenbsd.pod /perlos2.pod @@ -37,8 +33,6 @@ /perltru64.pod /perltw.pod /perluniprops.pod -/perluts.pod -/perlvmesa.pod /perlvms.pod /perlvos.pod /perlwin32.pod @@ -59,7 +53,7 @@ /roffitall # generated -/perl5211delta.pod +/perl5212delta.pod /perlapi.pod /perlintern.pod *.html diff --git a/pod/perl.pod b/pod/perl.pod index 3b6dbf1..0e9fd05 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -179,6 +179,7 @@ aux a2p c2ph h2ph h2xs perlbug pl2pm pod2html pod2man s2p splain xsubpp perlhist Perl history records perldelta Perl changes since previous version + perl5211delta Perl changes in version 5.21.1 perl5210delta Perl changes in version 5.21.0 perl5200delta Perl changes in version 5.20.0 perl5182delta Perl changes in version 5.18.2 diff --git a/pod/perl5211delta.pod b/pod/perl5211delta.pod new file mode 100644 index 0000000..5ab17e5 --- /dev/null +++ b/pod/perl5211delta.pod @@ -0,0 +1,1042 @@ +=encoding utf8 + +=head1 NAME + +perl5211delta - what is new for perl v5.21.1 + +=head1 DESCRIPTION + +This document describes differences between the 5.21.0 release and the 5.21.1 +release. + +If you are upgrading from an earlier release such as 5.20.0, first read +L, which describes differences between 5.20.0 and 5.21.0. + +=head1 Notice + +This release removes a number of previously deprecated constructs, many +that have been around for a long time. Please see L +for more information. + +=head1 Core Enhancements + +=head2 Unicode 7.0 is now supported + +For details on what is in this release, see +L. + +=head2 Experimental C Backtrace API + +Starting from Perl 5.21.1, on some platforms Perl supports retrieving +the C level backtrace (similar to what symbolic debuggers like gdb do). + +The backtrace returns the stack trace of the C call frames, +with the symbol names (function names), the object names (like "perl"), +and if it can, also the source code locations (file:line). + +The supported platforms are Linux and OS X (some *BSD might work at +least partly, but they have not yet been tested). + +The feature needs to be enabled with C. + +Also included is a C API to retrieve backtraces. + +See L for more information. + +=head2 C now ignores any Unicode pattern white space + +The C regular expression modifier allows the pattern to contain +white space and comments, both of which are ignored, for improved +readability. Until now, not all the white space characters that Unicode +designates for this purpose were handled. The additional ones now +recognized are +U+0085 NEXT LINE, +U+200E LEFT-TO-RIGHT MARK, +U+200F RIGHT-TO-LEFT MARK, +U+2028 LINE SEPARATOR, +and +U+2029 PARAGRAPH SEPARATOR. + +=head2 S> can restrict which locale categories are affected + +It is now possible to pass a parameter to S> to specify +a subset of locale categories to be locale-aware, with the remaining +ones unaffected. See L for details. + +=head1 Incompatible Changes + +=head2 C<\N{}> with a sequence of multiple spaces is now a fatal error. + +This has been deprecated since v5.18. + +=head2 In double-quotish C<\cI>, I must now be a printable ASCII character + +In prior releases, failure to do this raised a deprecation warning. + +=head2 Splitting the tokens C<(?> and C<(*> in regular expressions is +now a fatal compilation error. + +These had been deprecated since v5.18. + +=head2 5 additional characters are treated as white space under C in +regex patterns (unless escaped) + +The use of these characters with C outside bracketed character +classes and when not preceded by a backslash has raised a deprecation +warning since v5.18. Now they will be ignored. See L +for the list of the five characters. + +=head2 Comment lines within S> now are ended only by a C<\n> + +S> is an experimental feature, introduced in v5.18. It operates +as if C is always enabled. But there was a difference, comment +lines (following a C<#> character) were terminated by anything matching +C<\R> which includes all vertical whitespace, such as form feeds. For +consistency, this is now changed to match what terminates comment lines +outside S>, namely a C<\n> (even if escaped), which is the +same as what terminates a heredoc string and formats. + +=head2 Omitting % and @ on hash and array names is no longer permitted + +Really old Perl let you omit the @ on array names and the % on hash +names in some spots. This has issued a deprecation warning since Perl +5.0, and is no longer permitted. + +=head2 C<"$!"> text is now in English outside C<"use locale"> scope + +Previously, the text, unlike almost everything else, always came out +based on the current underlying locale of the program. (Also affected +on some systems is C<"$^E>".) For programs that are unprepared to +handle locale, this can cause garbage text to be displayed. It's better +to display text that is translatable via some tool than garbage text +which is much harder to figure out. + +=head2 C<"$!"> text will be returned in UTF-8 when appropriate + +The stringification of C<$!> and C<$^E> will have the UTF-8 flag set +when the text is actually non-ASCII UTF-8. This will enable programs +that are set up to be locale-aware to properly output messages in the +user's native language. Code that needs to continue the 5.20 and +earlier behavior can do the stringification within the scopes of both +'use bytes' and 'use locale ":messages". No other Perl operations will +be affected by locale; only C<$!> and C<$^E> stringification. The +'bytes' pragma causes the UTF-8 flag to not be set, just as in previous +Perl releases. This resolves [perl #112208]. + +=head2 Support for C without explicit operator has been removed + +Starting regular expressions matching only once directly with the +question mark delimiter is now a syntax error, so that the question mark +can be available for use in new operators. Write C instead, +explicitly using the C operator: the question mark delimiter still +invokes match-once behaviour. + +=head2 C and C are now fatal errors + +These have been deprecated since v5.6.1 and have raised deprecation +warnings since v5.16. + +=head2 Using a hash or an array as a reference are now fatal errors. + +For example, C<%foo-E{"bar"}> now causes a fatal compilation +error. These have been deprecated since before v5.8, and have raised +deprecation warnings since then. + +=head1 Deprecations + +=head2 Using a NO-BREAK space in a character alias for C<\N{...}> is now +deprecated + +This non-graphic character is essentially indistinguishable from a +regular space, and so should not be allowed. See +L. + +=head2 A literal C<"{"> should now be escaped in a pattern + +If you want a literal left curly bracket (also called a left brace) in a +regular expression pattern, you should now escape it by either +preceding it with a backslash (C<"\{">) or enclosing it within square +brackets C<"[{]">, or by using C<\Q>; otherwise a deprecation warning +will be raised. This was first announced as forthcoming in the v5.16 +release; it will allow future extensions to the language to happen. + +=head1 Performance Enhancements + +=over 4 + +=item * + +Many internal functions have been refactored to improve performance and reduce +their memory footprints. + +L<[perl #121436]|https://rt.perl.org/Ticket/Display.html?id=121436> +L<[perl #121906]|https://rt.perl.org/Ticket/Display.html?id=121906> +L<[perl #121969]|https://rt.perl.org/Ticket/Display.html?id=121969> + +=item * + +C<-T> and C<-B> filetests will return sooner when an empty file is detected. + +L + +=back + +=head1 Modules and Pragmata + +=head2 Updated Modules and Pragmata + +=over 4 + +=item * + +The libnet collection of modules has been upgraded from version 1.25 to 1.27. + +There are only whitespace changes to the installed files. + +=item * + +A mismatch between the documentation and the code in utf8::downgrade() +was fixed in favour of the documentation. The optional second argument +is now correctly treated as a perl boolean (true/false semantics) and +not as an integer. + +=item * + +The Locale-Codes collection of modules has been upgraded from version 3.30 to 3.31. + +Fixed a bug in the scripts used to extract data from spreadsheets that +prevented the SHP currency code from being found. +L<[cpan #94229]|https://rt.cpan.org/Ticket/Display.html?id=94229> + +=item * + +L has been upgraded from version 1.96 to 2.00. + +=item * + +L has been upgraded from version 2.23 to 2.25. + +=item * + +L has been upgraded from version 1.48 to 1.49. + +=item * + +L has been upgraded from version 1.26 to 1.27. + +=item * + +L has been upgraded from version 1.18 to 1.19. + +=item * + +L has been upgraded from version 1.3301 to 1.34. + +Carp::Heavy now ignores version mismatches with Carp if Carp is newer +than 1.12, since Carp::Heavy's guts were merged into Carp at that +point. +L<[perl #121574]|https://rt.perl.org/Ticket/Display.html?id=121574> + +=item * + +L has been upgraded from version 1.40 to 1.41. + +=item * + +L has been upgraded from version 2.140640 to 2.141520. + +=item * + +L has been upgraded from version 2.151 to 2.152. + +Changes to resolve Coverity issues. + +XS dumps incorrectly stored the name of code references stored in a +GLOB. +L<[perl #122070]|https://rt.perl.org/Ticket/Display.html?id=122070> + +=item * + +L has been upgraded from version 1.16 to 1.17. + +=item * + +L has been upgraded from version 3.21 to 3.24. + +=item * + +L has been upgraded from version 5.88 to 5.92. + +=item * + +L has been upgraded from version 1.25 to 1.26. + +=item * + +L has been upgraded from version 2.60 to 2.62. + +B now has better error handling when the encoding name is nonexistent, +and a build breakage when upgrading L in perl-5.8.2 and earlier has +been fixed. + +=item * + +L has been upgraded from version 1.20_03 to 1.20_04. + +=item * + +L has been upgraded from version 5.70 to 5.71. + +=item * + +L has been upgraded from version 1.67 to 1.68. + +=item * + +L has been upgraded from version 1.01 to 1.02. + +=item * + +L has been upgraded from version 3.24 to 3.25. + +=item * + +L has been upgraded from version 3.24 to 3.25. + +=item * + +L has been upgraded from version 3.47 to 3.48. + +=item * + +L has been upgraded from version 0.16 to 0.17. + +Minor bug fixes and documentation fixes to Hash::Util::hash_stats() + +=item * + +L has been upgraded from version 1.31 to 1.32. + +=item * + +L has been upgraded from version 1.38 to 1.39. + +=item * + +L has been upgraded from version 1.03 to 1.04. + +=item * + +L has been upgraded from version 3.30 to 3.31. + +=item * + +L has been upgraded from version 1.9993 to 1.9995. + +Synchronize POD changes from the CPAN release. + +C<< Math::BigFloat->blog(x) >> would sometimes return blog(2*x) when +the accuracy was greater than 70 digits. + +The result of C<< Math::BigFloat->bdiv() >> in list context now +satisfies C<< x = quotient * divisor + remainder >>. + +=item * + +L has been upgraded from version 0.2606 to 0.2608. + +Synchronize POD changes from the CPAN release. + +=item * + +L has been upgraded from version 5.021001 to 5.021001_01. + +=item * + +L has been upgraded from version 1.000019 to 1.000024. + +Support installations on older perls with an L earlier +than 6.63_03 + +=item * + +L has been upgraded from version 1.12 to 1.13. + +=item * + +L has been upgraded from version 1.09 to 1.10. + +=item * + +L has been upgraded from version 1.44 to 1.45. + +fork() in the debugger under C will now create a new window for +the forked process. L<[perl +#121333]|https://rt.perl.org/Ticket/Display.html?id=121333> + +The debugger now saves the current working directory on startup and +restores it when you restart your program with C or C. L<[perl +#121509]|https://rt.perl.org/Ticket/Display.html?id=121509> + +=item * + +L has been upgraded from version 0.18 to 0.19. + +No changes in behaviour. + +=item * + +L has been upgraded from version 0.011 to 0.013. + +No changes in behaviour. + +=item * + +L has been upgraded from version 0.18 to 0.19. + +No changes in behaviour. + +=item * + +L has been upgraded from version 0.14 to 0.15. + +=item * + +L has been upgraded from version 1.21 to 1.22. + +=item * + +L has been upgraded from version 1.38_03 to 1.40. + +=item * + +L has been upgraded from version 1.38 to 1.39. + +=item * + +L has been upgraded from version 1.21 to 1.22. + +=item * + +L has been upgraded from version 2.013 to 2.014. + +=item * + +L has been upgraded from version 2.49 to 2.51. + +=item * + +L has been upgraded from version 4.02 to 4.03. + +=item * + +L has been upgraded from version 3.30 to 3.32. + +=item * + +L has been upgraded from version 1.001002 to 1.001003. + +=item * + +L has been upgraded from version 1.93 to 1.94. + +=item * + +L has been upgraded from version 1.00 to 1.01. + +=item * + +L has been upgraded from version 1.04 to 1.07. + +Version 0.67's improved discontiguous contractions is invalidated by default +and is supported as a parameter 'long_contraction'. + +=item * + +L has been upgraded from version 1.17 to 1.18. + +The XSUB implementation has been removed in favour of pure Perl. + +=item * + +L has been upgraded from version 0.57 to 0.58. + +=item * + +L has been upgraded from version 1.13 to 1.14. + +=item * + +L has been upgraded from version 1.23 to 1.24. + +=back + +=head1 Documentation + +=head2 Changes to Existing Documentation + +=head3 L + +=over 4 + +=item * + +C<-l> now notes that it will return false if symlinks aren't supported by the +file system. + +L<[perl #121523]|https://rt.perl.org/Ticket/Display.html?id=121523> + +=item * + +Note that C and C may fall back to the shell on +Win32. Only C and C indirect object +syntax will reliably avoid using the shell. + +This has also been noted in L. + +L<[perl #122046]|https://rt.perl.org/Ticket/Display.html?id=122046> + +=back + +=head3 L + +=over 4 + +=item * + +Note that C doesn't do set magic. + +=item * + +C - Fix documentation to mention the use of C instead of +C. + +L<[perl #121869]|https://rt.perl.org/Ticket/Display.html?id=121869> + +=item * + +Clarify where C may be embedded or is required to terminate a string. + +=item * + +Previously missing documentation due to formatting errors are now included. + +=item * + +Entries are now organized into groups rather than by file where they are found. + +=item * + +Alphabetical sorting of entries is now handled by the POD generator to make +entries easier to find when scanning. + +=back + +=head3 L + +=over 4 + +=item * + +Updated documentation for the C C target. + +L<[perl #121431]|https://rt.perl.org/Ticket/Display.html?id=121431> + +=back + +=head3 L + +=over 4 + +=item * + +The C modifier has been clarified to note that comments cannot be continued +onto the next line by escaping them. + +=back + +=head3 L + +=over 4 + +=item * + +The documentation includes many clarifications and fixes. + +=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 in mE%sE|perldiag/"In '(?...)', the '(' and '?' must be adjacent in regex; marked by <-- HERE in m/%s/"> + +(F) The two-character sequence C<"(?"> in +this context in a regular expression pattern should be an +indivisible token, with nothing intervening between the C<"("> +and the C<"?">, but you separated them. + +=item * + +L in mE%sE|perldiag/"In '(*VERB...)', the '(' and '*' must be adjacent in regex; marked by <-- HERE in m/%s/"> + +(F) The two-character sequence C<"(*"> in +this context in a regular expression pattern should be an +indivisible token, with nothing intervening between the C<"("> +and the C<"*">, but you separated them. + +=item * + +L + +(F) You defined a character name which had multiple space + characters in a row. Change them to single spaces. Usually these + names are defined in the C<:alias> import argument to C, but + they could be defined by a translator installed into C<$^H{charnames}>. + See L. + +=item * + +L + +(F) You defined a character name which ended in a space +character. Remove the trailing space(s). Usually these names are +defined in the C<:alias> import argument to C, but they +could be defined by a translator installed into C<$^H{charnames}>. +See L. + +=item * + +L + +(F) You tried to use a hash as a reference, as in +C<< %foo->{"bar"} >> or C<< %$ref->{"hello"} >>. Versions of perl E= 5.6.1 +used to allow this syntax, but shouldn't have. + +=item * + +L + +(F) You tried to use an array as a reference, as in +C<< @foo->[23] >> or C<< @$ref->[99] >>. Versions of perl E= 5.6.1 used to +allow this syntax, but shouldn't have. + +=item * + +L + +(F) defined() is not useful on arrays because it +checks for an undefined I value. If you want to see if the +array is empty, just use C for example. + +=item * + +L + +(F) C is not usually right on hashes. + +Although C is false on a plain not-yet-used hash, it +becomes true in several non-obvious circumstances, including iterators, +weak references, stash names, even remaining true after C. +These things make C fairly useless in practice, so it now +generates a fatal error. + +If a check for non-empty is what you wanted then just put it in boolean +context (see L): + + if (%hash) { + # not empty + } + +If you had C to check whether such a package +variable exists then that's never really been reliable, and isn't +a good way to enquire about the features of a package, or whether +it's loaded, etc. + +=item * + +L + +(F) The script run under suidperl was somehow illegal. + +=back + +=head3 New Warnings + +=over 4 + +=item * + +L%sE|perldiag/"Unescaped left brace in regex is deprecated, passed through in regex; marked by <-- HERE in m/%s/"> + +(D deprecated, regexp) You used a literal C<"{"> character in a regular +expression pattern. You should change to use C<"\{"> instead, because a future +version of Perl (tentatively v5.26) will consider this to be a syntax error. If +the pattern delimiters are also braces, any matching right brace +(C<"}">) should also be escaped to avoid confusing the parser, for +example, + + qr{abc\{def\}ghi} + +=item * + +L + +(D deprecated) You defined a character name which contained a no-break +space character. Change it to a regular space. Usually these names are +defined in the C<:alias> import argument to C, but they +could be defined by a translator installed into C<$^H{charnames}>. See +L. + +=item * + +L + +(S experimental::win32_perlio) The C<:win32> PerlIO layer is +experimental. If you want to take the risk of using this layer, +simply disable this warning: + + no warnings "experimental::win32_perlio"; + +=item * + +L + +(W numeric) You tried to execute the +L|perlop/Multiplicative Operators> repetition operator fewer than 0 +times, which doesn't make sense. + +=item * + +L + +(W overflow) You called C with a number that it could not handle: +too large, too small, or NaN. The returned value is C. + +=item * + +L + +(W overflow) You called C with a number that it could not handle: +too large, too small, or NaN. The returned value is C. + +=item * + +L: + +(S experimental::win32_perlio) The C<:win32> PerlIO layer is +experimental. If you want to take the risk of using this layer, +simply disable this warning: + + no warnings "experimental::win32_perlio"; + +=item * + +L + +(W numeric) This warns when the repeat count of the +L|perlop/Multiplicative Operators> repetition operator is +negative. + +This warning may be changed or removed if it turn out that it was +unwise to have added it. + +=back + +=head2 Changes to Existing Diagnostics + +=over 4 + +=item * + +L%sE|perldiag/"Variable length lookbehind not implemented in regex m/%s/"> + +Information about Unicode behaviour has been added. + +=item * + +<> should be quotes + +This warning has been changed to +L<< <> at require-statement should be quotes|perldiag/"<> at require-statement should be quotes" >> +to make the issue more identifiable. + +=item * + +L + +This warning is now only produced when the newline is at the end of +the filename. + +=back + +=head1 Utility Changes + +=head2 F + +=over 4 + +=item * + +The F directory has been removed from the Perl core. + +This removes find2perl, s2p and a2p. They have all been released to CPAN as +separate distributions (App::find2perl, App::s2p, App::a2p). + +=back + +=head1 Configuration and Compilation + +=over 4 + +=item * + +C now supports parallel testing. + +For example: + + TEST_JOBS=9 make test.valgrind + +See L for more information. + +L<[perl #121431]|https://rt.perl.org/Ticket/Display.html?id=121431> + +=item * + +The MAD (Misc Attribute Decoration) build option has been removed + +This was an unmaintained attempt at preserving +the Perl parse tree more faithfully so that automatic conversion of +Perl 5 to Perl 6 would have been easier. + +This build-time configuration option had been unmaintained for years, +and had probably seriously diverged on both Perl 5 and Perl 6 sides. + +=back + +=head1 Platform Support + +=head2 Discontinued Platforms + +=over 4 + +=item NeXTSTEP/OPENSTEP + +NeXTSTEP was proprietary OS bundled with NeXT's workstations in the early +to mid 90's; OPENSTEP was an API specification that provided a NeXTSTEP-like +environment on a non-NeXTSTEP system. Both are now long dead, so support +for building Perl on them has been removed. + +=back + +=head2 Platform-Specific Notes + +=over 4 + +=item OpenBSD + +On OpenBSD, Perl will now default to using the system C due to the +security features it provides. Perl's own malloc wrapper has been in use +since v5.14 due to performance reasons, but the OpenBSD project believes +the tradeoff is worth it and would prefer that users who need the speed +specifically ask for it. + +L<[perl #122000]|https://rt.perl.org/Ticket/Display.html?id=122000>. + +=back + +=head1 Internal Changes + +=over 4 + +=item * + +The deprecated variable C has been removed. + +=item * + +Perl now tries to keep the locale category C set to "C" +except around operations that need it to be set to the program's +underlying locale. This protects the many XS modules that cannot cope +with the decimal radix character not being a dot. Prior to this +release, Perl initialized this category to "C", but a call to +C would change it. Now such a call will change the +underlying locale of the C category for the program, but the +locale exposed to XS code will remain "C". There is an API under +development for those relatively few modules that need to use the +underlying locale. This API will be nailed down during the course of +developing v5.21. Send email to L for +guidance. + +=item * + +A new macro L|perlapi/isUTF8_CHAR> has been written which +efficiently determines if the string given by its parameters begins +with a well-formed UTF-8 encoded character. + +=back + +=head1 Selected Bug Fixes + +=over 4 + +=item * + +index() and rindex() no longer crash when used on strings over 2GB in +size. +L<[perl #121562]|https://rt.perl.org/Ticket/Display.html?id=121562>. + +=item * + +A small previously intentional memory leak in PERL_SYS_INIT/PERL_SYS_INIT3 on +Win32 builds was fixed. This might affect embedders who repeatedly create and +destroy perl engines within the same process. + +=item * + +C now returns the data for the program's underlying +locale even when called from outside the scope of S>. + +=item * + +C now works properly on platforms which don't have +C and/or C, or for which Perl has been compiled +to disregard either or both of these locale categories. In such +circumstances, there are now no entries for the corresponding values in +the hash returned by C. + +=item * + +C now marks appropriately the values it returns as +UTF-8 or not. Previously they were always returned as a bytes, even if +they were supposed to be encoded as UTF-8. + +=item * + +On Microsoft Windows, within the scope of C>, the following +POSIX character classes gave results for many locales that did not +conform to the POSIX standard: +C<[[:alnum:]]>, +C<[[:alpha:]]>, +C<[[:blank:]]>, +C<[[:digit:]]>, +C<[[:graph:]]>, +C<[[:lower:]]>, +C<[[:print:]]>, +C<[[:punct:]]>, +C<[[:upper:]]>, +C<[[:word:]]>, +and +C<[[:xdigit:]]>. +These are because the underlying Microsoft implementation does not +follow the standard. Perl now takes special precautions to correct for +this. + +=item * + +Many issues have been detected by L and +fixed. + +=item * + +system() and friends should now work properly on more Android builds. + +Due to an oversight, the value specified through -Dtargetsh to Configure +would end up being ignored by some of the build process. This caused perls +cross-compiled for Android to end up with defective versions of system(), +exec() and backticks: the commands would end up looking for C +instead of C, and so would fail for the vast majority +of devices, leaving C<$!> as C. + +=item * + +C, +C, +and +C +now work. Previously it was impossible to escape these three +left-characters with a backslash within a regular expression pattern +where otherwise they would be considered metacharacters, and the pattern +opening delimiter was the character, and the closing delimiter was its +mirror character. + +=back + +=head1 Acknowledgements + +Perl 5.21.1 represents approximately 3 weeks of development since Perl 5.21.0 +and contains approximately 240,000 lines of changes across 680 files from 37 +authors. + +Excluding auto-generated files, documentation and release tools, there were +approximately 150,000 lines of changes to 420 .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.21.1: + +Alex Solovey, Andrew Fresh, Andy Dougherty, Brian Fraser, Chris 'BinGOs' +Williams, Craig A. Berry, Dagfinn Ilmari MannsÃ¥ker, Daniel Dragan, Darin +McBride, David Mitchell, Doug Bell, H.Merijn Brand, James E Keenan, Jarkko +Hietaniemi, kafka, Karen Etheridge, Karl Williamson, Leon Timmermans, Matthew +Horsfall, Michael Bunk, Nicholas Clark, Niels Thykier, Norman Koch, Peter John +Acklam, Pierre Bogossian, Reini Urban, Ricardo Signes, Rob Hoelz, Shlomi Fish, +Smylers, Steffen Müller, Steve Hay, Sullivan Beck, Thomas Sibley, Todd +Rinaldo, Tony Cook, 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 +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 +https://rt.perl.org/ . There may also be information at +http://www.perl.org/ , 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/perldelta.pod b/pod/perldelta.pod index 84db09e..974a62c 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -2,163 +2,45 @@ =head1 NAME -perldelta - what is new for perl v5.21.1 +perldelta - what is new for perl v5.21.2 =head1 DESCRIPTION -This document describes differences between the 5.21.0 release and the 5.21.1 +This document describes differences between the 5.21.1 release and the 5.21.2 release. -If you are upgrading from an earlier release such as 5.20.0, first read -L, which describes differences between 5.20.0 and 5.21.0. - -=head1 Notice - -This release removes a number of previously deprecated constructs, many -that have been around for a long time. Please see L -for more information. +If you are upgrading from an earlier release such as 5.21.0, first read +L, which describes differences between 5.21.0 and 5.21.1. =head1 Core Enhancements -=head2 Unicode 7.0 is now supported - -For details on what is in this release, see -L. - -=head2 Experimental C Backtrace API - -Starting from Perl 5.21.1, on some platforms Perl supports retrieving -the C level backtrace (similar to what symbolic debuggers like gdb do). - -The backtrace returns the stack trace of the C call frames, -with the symbol names (function names), the object names (like "perl"), -and if it can, also the source code locations (file:line). - -The supported platforms are Linux and OS X (some *BSD might work at -least partly, but they have not yet been tested). - -The feature needs to be enabled with C. - -Also included is a C API to retrieve backtraces. - -See L for more information. - -=head2 C now ignores any Unicode pattern white space - -The C regular expression modifier allows the pattern to contain -white space and comments, both of which are ignored, for improved -readability. Until now, not all the white space characters that Unicode -designates for this purpose were handled. The additional ones now -recognized are -U+0085 NEXT LINE, -U+200E LEFT-TO-RIGHT MARK, -U+200F RIGHT-TO-LEFT MARK, -U+2028 LINE SEPARATOR, -and -U+2029 PARAGRAPH SEPARATOR. - -=head2 S> can restrict which locale categories are affected - -It is now possible to pass a parameter to S> to specify -a subset of locale categories to be locale-aware, with the remaining -ones unaffected. See L for details. - -=head1 Incompatible Changes - -=head2 C<\N{}> with a sequence of multiple spaces is now a fatal error. - -This has been deprecated since v5.18. - -=head2 In double-quotish C<\cI>, I must now be a printable ASCII character - -In prior releases, failure to do this raised a deprecation warning. - -=head2 Splitting the tokens C<(?> and C<(*> in regular expressions is -now a fatal compilation error. - -These had been deprecated since v5.18. - -=head2 5 additional characters are treated as white space under C in -regex patterns (unless escaped) +=head2 Better heuristics on older platforms for determining locale UTF8ness -The use of these characters with C outside bracketed character -classes and when not preceded by a backslash has raised a deprecation -warning since v5.18. Now they will be ignored. See L -for the list of the five characters. +On platforms that implement neither the C99 standard nor the POSIX 2001 +standard, determining if the current locale is UTF8 or not depends on +heuristics. These are improved in this release. -=head2 Comment lines within S> now are ended only by a C<\n> +=head1 Security -S> is an experimental feature, introduced in v5.18. It operates -as if C is always enabled. But there was a difference, comment -lines (following a C<#> character) were terminated by anything matching -C<\R> which includes all vertical whitespace, such as form feeds. For -consistency, this is now changed to match what terminates comment lines -outside S>, namely a C<\n> (even if escaped), which is the -same as what terminates a heredoc string and formats. +=head2 Perl is now always compiled with -D_FORTIFY_SOURCE=2 if available -=head2 Omitting % and @ on hash and array names is no longer permitted +The 'code hardening' option called C<_FORTIFY_SOURCE>, available in +gcc 4.*, is now always used for compiling Perl, if available. -Really old Perl let you omit the @ on array names and the % on hash -names in some spots. This has issued a deprecation warning since Perl -5.0, and is no longer permitted. +Note that this isn't necessarily a huge step since in many platforms +the step had already been taken several years ago: many Linux +distributions (like Fedora) have been using this option for Perl, +and OS X has enforced the same for many years. -=head2 C<"$!"> text is now in English outside C<"use locale"> scope - -Previously, the text, unlike almost everything else, always came out -based on the current underlying locale of the program. (Also affected -on some systems is C<"$^E>".) For programs that are unprepared to -handle locale, this can cause garbage text to be displayed. It's better -to display text that is translatable via some tool than garbage text -which is much harder to figure out. - -=head2 C<"$!"> text will be returned in UTF-8 when appropriate - -The stringification of C<$!> and C<$^E> will have the UTF-8 flag set -when the text is actually non-ASCII UTF-8. This will enable programs -that are set up to be locale-aware to properly output messages in the -user's native language. Code that needs to continue the 5.20 and -earlier behavior can do the stringification within the scopes of both -'use bytes' and 'use locale ":messages". No other Perl operations will -be affected by locale; only C<$!> and C<$^E> stringification. The -'bytes' pragma causes the UTF-8 flag to not be set, just as in previous -Perl releases. This resolves [perl #112208]. - -=head2 Support for C without explicit operator has been removed - -Starting regular expressions matching only once directly with the -question mark delimiter is now a syntax error, so that the question mark -can be available for use in new operators. Write C instead, -explicitly using the C operator: the question mark delimiter still -invokes match-once behaviour. - -=head2 C and C are now fatal errors - -These have been deprecated since v5.6.1 and have raised deprecation -warnings since v5.16. - -=head2 Using a hash or an array as a reference are now fatal errors. - -For example, C<%foo-E{"bar"}> now causes a fatal compilation -error. These have been deprecated since before v5.8, and have raised -deprecation warnings since then. =head1 Deprecations -=head2 Using a NO-BREAK space in a character alias for C<\N{...}> is now -deprecated - -This non-graphic character is essentially indistinguishable from a -regular space, and so should not be allowed. See -L. - -=head2 A literal C<"{"> should now be escaped in a pattern +=head2 C<< /\C/ >> character class -If you want a literal left curly bracket (also called a left brace) in a -regular expression pattern, you should now escape it by either -preceding it with a backslash (C<"\{">) or enclosing it within square -brackets C<"[{]">, or by using C<\Q>; otherwise a deprecation warning -will be raised. This was first announced as forthcoming in the v5.16 -release; it will allow future extensions to the language to happen. +This character class, which matches a single byte, even if it appears +in a multi-byte character has been deprecated. Matching single bytes +in a multi-byte character breaks encapsulation, and can corrupt utf8 +strings. =head1 Performance Enhancements @@ -166,308 +48,108 @@ release; it will allow future extensions to the language to happen. =item * -Many internal functions have been refactored to improve performance and reduce -their memory footprints. - -L<[perl #121436]|https://rt.perl.org/Ticket/Display.html?id=121436> -L<[perl #121906]|https://rt.perl.org/Ticket/Display.html?id=121906> -L<[perl #121969]|https://rt.perl.org/Ticket/Display.html?id=121969> - -=item * - -C<-T> and C<-B> filetests will return sooner when an empty file is detected. - -L - -=back - -=head1 Modules and Pragmata - -=head2 Updated Modules and Pragmata - -=over 4 - -=item * - -The libnet collection of modules has been upgraded from version 1.25 to 1.27. - -There are only whitespace changes to the installed files. - -=item * - -A mismatch between the documentation and the code in utf8::downgrade() -was fixed in favour of the documentation. The optional second argument -is now correctly treated as a perl boolean (true/false semantics) and -not as an integer. - -=item * - -The Locale-Codes collection of modules has been upgraded from version 3.30 to 3.31. - -Fixed a bug in the scripts used to extract data from spreadsheets that -prevented the SHP currency code from being found. -L<[cpan #94229]|https://rt.cpan.org/Ticket/Display.html?id=94229> - -=item * - -L has been upgraded from version 1.96 to 2.00. - -=item * - -L has been upgraded from version 2.23 to 2.25. - -=item * - -L has been upgraded from version 1.48 to 1.49. - -=item * - -L has been upgraded from version 1.26 to 1.27. - -=item * - -L has been upgraded from version 1.18 to 1.19. - -=item * - -L has been upgraded from version 1.3301 to 1.34. - -Carp::Heavy now ignores version mismatches with Carp if Carp is newer -than 1.12, since Carp::Heavy's guts were merged into Carp at that -point. -L<[perl #121574]|https://rt.perl.org/Ticket/Display.html?id=121574> - -=item * - -L has been upgraded from version 1.40 to 1.41. - -=item * - -L has been upgraded from version 2.140640 to 2.141520. - -=item * - -L has been upgraded from version 2.151 to 2.152. - -Changes to resolve Coverity issues. - -XS dumps incorrectly stored the name of code references stored in a -GLOB. -L<[perl #122070]|https://rt.perl.org/Ticket/Display.html?id=122070> - -=item * - -L has been upgraded from version 1.16 to 1.17. - -=item * - -L has been upgraded from version 3.21 to 3.24. - -=item * - -L has been upgraded from version 5.88 to 5.92. - -=item * - -L has been upgraded from version 1.25 to 1.26. - -=item * - -L has been upgraded from version 2.60 to 2.62. - -B now has better error handling when the encoding name is nonexistent, -and a build breakage when upgrading L in perl-5.8.2 and earlier has -been fixed. - -=item * - -L has been upgraded from version 1.20_03 to 1.20_04. - -=item * - -L has been upgraded from version 5.70 to 5.71. - -=item * - -L has been upgraded from version 1.67 to 1.68. - -=item * - -L has been upgraded from version 1.01 to 1.02. - -=item * - -L has been upgraded from version 3.24 to 3.25. - -=item * - -L has been upgraded from version 3.24 to 3.25. - -=item * - -L has been upgraded from version 3.47 to 3.48. - -=item * - -L has been upgraded from version 0.16 to 0.17. - -Minor bug fixes and documentation fixes to Hash::Util::hash_stats() +Refactoring of C<< pp_tied >> and CC<< pp_ref >> for small improvements. =item * -L has been upgraded from version 1.31 to 1.32. +Pathtools don't try to load XS on miniperl. =item * -L has been upgraded from version 1.38 to 1.39. +A typo fix reduces the size of the C<< OP >> structure. =item * -L has been upgraded from version 1.03 to 1.04. +Hash lookups where the key is a constant is faster. -=item * - -L has been upgraded from version 3.30 to 3.31. - -=item * - -L has been upgraded from version 1.9993 to 1.9995. - -Synchronize POD changes from the CPAN release. - -C<< Math::BigFloat->blog(x) >> would sometimes return blog(2*x) when -the accuracy was greater than 70 digits. - -The result of C<< Math::BigFloat->bdiv() >> in list context now -satisfies C<< x = quotient * divisor + remainder >>. - -=item * - -L has been upgraded from version 0.2606 to 0.2608. - -Synchronize POD changes from the CPAN release. - -=item * - -L has been upgraded from version 5.021001 to 5.021001_01. - -=item * - -L has been upgraded from version 1.000019 to 1.000024. - -Support installations on older perls with an L earlier -than 6.63_03 - -=item * +=back -L has been upgraded from version 1.12 to 1.13. +=head1 Modules and Pragmata -=item * +=head2 Updated Modules and Pragmata -L has been upgraded from version 1.09 to 1.10. +=over 4 =item * -L has been upgraded from version 1.44 to 1.45. - -fork() in the debugger under C will now create a new window for -the forked process. L<[perl -#121333]|https://rt.perl.org/Ticket/Display.html?id=121333> - -The debugger now saves the current working directory on startup and -restores it when you restart your program with C or C. L<[perl -#121509]|https://rt.perl.org/Ticket/Display.html?id=121509> +L has been upgraded from version 0.07 to 0.08. =item * -L has been upgraded from version 0.18 to 0.19. - -No changes in behaviour. +L has been upgraded from version 1.49 to 1.50. =item * -L has been upgraded from version 0.011 to 0.013. - -No changes in behaviour. +L has been upgraded from version 1.17 to 1.18. =item * -L has been upgraded from version 0.18 to 0.19. - -No changes in behaviour. +L has been upgraded from version 0.007 to 0.008. =item * -L has been upgraded from version 0.14 to 0.15. +L has been upgraded from version 1.63 to 1.64. =item * -L has been upgraded from version 1.21 to 1.22. +L has been upgraded from version 2.29 to 2.30. =item * -L has been upgraded from version 1.38_03 to 1.40. +The PathTools module collection (L and friends) has been +upgraded from version 3.48 to 3.49. =item * -L has been upgraded from version 1.38 to 1.39. +L has been upgraded from version 0.91 to 0.92. =item * -L has been upgraded from version 1.21 to 1.22. +L has been upgraded from version 0.17 to 0.18. =item * -L has been upgraded from version 2.013 to 2.014. +L has been upgraded from version 1.32 to 1.33. =item * -L has been upgraded from version 2.49 to 2.51. +L has been upgraded from version 0.29 to 0.31. -=item * - -L has been upgraded from version 4.02 to 4.03. +A better fix for subclassing C. +L<[cpan #95983]|https://rt.cpan.org/Ticket/Display.html?id=95983> +L<[cpan #97050]|https://rt.cpan.org/Ticket/Display.html?id=97050> =item * -L has been upgraded from version 3.30 to 3.32. +L has been upgraded from version 1.16 to 1.17. =item * -L has been upgraded from version 1.001002 to 1.001003. - -=item * - -L has been upgraded from version 1.93 to 1.94. - -=item * +L has been upgraded from version 1.9995 to 1.9996. -L has been upgraded from version 1.00 to 1.01. +Correct handling of subclasses. +L<[cpan #96254]|https://rt.cpan.org/Ticket/Display.html?id=96254> +L<[cpan #96329]|https://rt.cpan.org/Ticket/Display.html?id=96329> =item * -L has been upgraded from version 1.04 to 1.07. - -Version 0.67's improved discontiguous contractions is invalidated by default -and is supported as a parameter 'long_contraction'. +L has been upgraded from version 5.021001_01 to 5.021002. =item * -L has been upgraded from version 1.17 to 1.18. - -The XSUB implementation has been removed in favour of pure Perl. +L has been upgraded from version 1.63 to 1.64. =item * -L has been upgraded from version 0.57 to 0.58. +L has been upgraded from version 1.40 to 1.41. =item * -L has been upgraded from version 1.13 to 1.14. +L has been upgraded from version 1.94 to 1.95. =item * -L has been upgraded from version 1.23 to 1.24. +L has been upgraded from version 1.24 to 1.26. =back @@ -475,383 +157,102 @@ L has been upgraded from version 1.23 to 1.24. =head2 Changes to Existing Documentation -=head3 L +=head3 L<< perlpolicy >> =over 4 =item * -C<-l> now notes that it will return false if symlinks aren't supported by the -file system. - -L<[perl #121523]|https://rt.perl.org/Ticket/Display.html?id=121523> - -=item * - -Note that C and C may fall back to the shell on -Win32. Only C and C indirect object -syntax will reliably avoid using the shell. - -This has also been noted in L. - -L<[perl #122046]|https://rt.perl.org/Ticket/Display.html?id=122046> +We now have a code of conduct for the I<< p5p >> mailing list, as documented +in L<< perlpolicy/STANDARDS OF CONDUCT >>. =back -=head3 L +=head3 L<< perlfunc >> =over 4 =item * -Note that C doesn't do set magic. - -=item * - -C - Fix documentation to mention the use of C instead of -C. - -L<[perl #121869]|https://rt.perl.org/Ticket/Display.html?id=121869> - -=item * - -Clarify where C may be embedded or is required to terminate a string. - -=item * - -Previously missing documentation due to formatting errors are now included. - -=item * - -Entries are now organized into groups rather than by file where they are found. - -=item * - -Alphabetical sorting of entries is now handled by the POD generator to make -entries easier to find when scanning. +Improve documentation of C<< our >>. =back -=head3 L +=head3 L<< perlsyn >> =over 4 =item * -Updated documentation for the C C target. - -L<[perl #121431]|https://rt.perl.org/Ticket/Display.html?id=121431> - -=back - -=head3 L - -=over 4 - -=item * - -The C modifier has been clarified to note that comments cannot be continued -onto the next line by escaping them. - -=back - -=head3 L - -=over 4 - -=item * - -The documentation includes many clarifications and fixes. +The empty conditional in C<< for >> and C<< while >> is now documented +in L<< perlsyn >>. =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 in mE%sE|perldiag/"In '(?...)', the '(' and '?' must be adjacent in regex; marked by <-- HERE in m/%s/"> - -(F) The two-character sequence C<"(?"> in -this context in a regular expression pattern should be an -indivisible token, with nothing intervening between the C<"("> -and the C<"?">, but you separated them. - -=item * - -L in mE%sE|perldiag/"In '(*VERB...)', the '(' and '*' must be adjacent in regex; marked by <-- HERE in m/%s/"> - -(F) The two-character sequence C<"(*"> in -this context in a regular expression pattern should be an -indivisible token, with nothing intervening between the C<"("> -and the C<"*">, but you separated them. - -=item * - -L - -(F) You defined a character name which had multiple space - characters in a row. Change them to single spaces. Usually these - names are defined in the C<:alias> import argument to C, but - they could be defined by a translator installed into C<$^H{charnames}>. - See L. - -=item * - -L - -(F) You defined a character name which ended in a space -character. Remove the trailing space(s). Usually these names are -defined in the C<:alias> import argument to C, but they -could be defined by a translator installed into C<$^H{charnames}>. -See L. - -=item * - -L - -(F) You tried to use a hash as a reference, as in -C<< %foo->{"bar"} >> or C<< %$ref->{"hello"} >>. Versions of perl E= 5.6.1 -used to allow this syntax, but shouldn't have. - -=item * - -L - -(F) You tried to use an array as a reference, as in -C<< @foo->[23] >> or C<< @$ref->[99] >>. Versions of perl E= 5.6.1 used to -allow this syntax, but shouldn't have. - -=item * - -L - -(F) defined() is not useful on arrays because it -checks for an undefined I value. If you want to see if the -array is empty, just use C for example. - -=item * - -L - -(F) C is not usually right on hashes. - -Although C is false on a plain not-yet-used hash, it -becomes true in several non-obvious circumstances, including iterators, -weak references, stash names, even remaining true after C. -These things make C fairly useless in practice, so it now -generates a fatal error. - -If a check for non-empty is what you wanted then just put it in boolean -context (see L): - - if (%hash) { - # not empty - } - -If you had C to check whether such a package -variable exists then that's never really been reliable, and isn't -a good way to enquire about the features of a package, or whether -it's loaded, etc. - -=item * - -L - -(F) The script run under suidperl was somehow illegal. - -=back - =head3 New Warnings =over 4 =item * -L%sE|perldiag/"Unescaped left brace in regex is deprecated, passed through in regex; marked by <-- HERE in m/%s/"> +L -(D deprecated, regexp) You used a literal C<"{"> character in a regular -expression pattern. You should change to use C<"\{"> instead, because a future -version of Perl (tentatively v5.26) will consider this to be a syntax error. If -the pattern delimiters are also braces, any matching right brace -(C<"}">) should also be escaped to avoid confusing the parser, for -example, - - qr{abc\{def\}ghi} +(W numeric) The indicated string was fed as an argument to the C<++> operator +which expects either a number or a string matching C. +See L for details. =item * -L +L -(D deprecated) You defined a character name which contained a no-break -space character. Change it to a regular space. Usually these names are -defined in the C<:alias> import argument to C, but they -could be defined by a translator installed into C<$^H{charnames}>. See -L. +(W redundant) You called a function with more arguments than other +arguments you supplied indicated would be needed. Currently only +emitted when a printf-type format required fewer arguments than were +supplied, but might be used in the future for e.g. L. -=item * - -L - -(S experimental::win32_perlio) The C<:win32> PerlIO layer is -experimental. If you want to take the risk of using this layer, -simply disable this warning: - - no warnings "experimental::win32_perlio"; - -=item * - -L - -(W numeric) You tried to execute the -L|perlop/Multiplicative Operators> repetition operator fewer than 0 -times, which doesn't make sense. - -=item * - -L - -(W overflow) You called C with a number that it could not handle: -too large, too small, or NaN. The returned value is C. - -=item * - -L - -(W overflow) You called C with a number that it could not handle: -too large, too small, or NaN. The returned value is C. - -=item * - -L: - -(S experimental::win32_perlio) The C<:win32> PerlIO layer is -experimental. If you want to take the risk of using this layer, -simply disable this warning: - - no warnings "experimental::win32_perlio"; - -=item * - -L - -(W numeric) This warns when the repeat count of the -L|perlop/Multiplicative Operators> repetition operator is -negative. - -This warning may be changed or removed if it turn out that it was -unwise to have added it. - -=back - -=head2 Changes to Existing Diagnostics - -=over 4 - -=item * - -L%sE|perldiag/"Variable length lookbehind not implemented in regex m/%s/"> - -Information about Unicode behaviour has been added. - -=item * - -<> should be quotes - -This warning has been changed to -L<< <> at require-statement should be quotes|perldiag/"<> at require-statement should be quotes" >> -to make the issue more identifiable. - -=item * - -L - -This warning is now only produced when the newline is at the end of -the filename. +The warnings category C<< redundant >> is new. See also [RT #121025] =back -=head1 Utility Changes - -=head2 F +=head1 Configuration and Compilation =over 4 =item * -The F directory has been removed from the Perl core. - -This removes find2perl, s2p and a2p. They have all been released to CPAN as -separate distributions (App::find2perl, App::s2p, App::a2p). +A new compilation flag, C<< -DPERL_OP_PARENT >> is available. For details, +see the discussion below at L<< /Internal Changes >>. =back -=head1 Configuration and Compilation +=head1 Testing =over 4 =item * -C now supports parallel testing. - -For example: - - TEST_JOBS=9 make test.valgrind - -See L for more information. - -L<[perl #121431]|https://rt.perl.org/Ticket/Display.html?id=121431> - -=item * - -The MAD (Misc Attribute Decoration) build option has been removed - -This was an unmaintained attempt at preserving -the Perl parse tree more faithfully so that automatic conversion of -Perl 5 to Perl 6 would have been easier. - -This build-time configuration option had been unmaintained for years, -and had probably seriously diverged on both Perl 5 and Perl 6 sides. +C<< test.pl >> now allows C<< plan skip_all => $reason >>, to make it +more compatible with C<< Test::More >>. =back =head1 Platform Support -=head2 Discontinued Platforms - -=over 4 - -=item NeXTSTEP/OPENSTEP - -NeXTSTEP was proprietary OS bundled with NeXT's workstations in the early -to mid 90's; OPENSTEP was an API specification that provided a NeXTSTEP-like -environment on a non-NeXTSTEP system. Both are now long dead, so support -for building Perl on them has been removed. - -=back - =head2 Platform-Specific Notes =over 4 -=item OpenBSD - -On OpenBSD, Perl will now default to using the system C due to the -security features it provides. Perl's own malloc wrapper has been in use -since v5.14 due to performance reasons, but the OpenBSD project believes -the tradeoff is worth it and would prefer that users who need the speed -specifically ask for it. +=item Solaris -L<[perl #122000]|https://rt.perl.org/Ticket/Display.html?id=122000>. +Builds on Solaris 10 with C<-Dusedtrace> would fail early since make +didn't follow implied dependencies to build C. Added an +explicit dependency to C. +L<[perl #120120]|https://rt.perl.org/Ticket/Display.html?id=120120> =back @@ -861,28 +262,28 @@ L<[perl #122000]|https://rt.perl.org/Ticket/Display.html?id=122000>. =item * -The deprecated variable C has been removed. +The following private API functions had their context parameter removed, +C, C, C, C, +C, C, C, C, +C, C, C, C. + +Users of the public API prefix-less calls remain unaffected. =item * -Perl now tries to keep the locale category C set to "C" -except around operations that need it to be set to the program's -underlying locale. This protects the many XS modules that cannot cope -with the decimal radix character not being a dot. Prior to this -release, Perl initialized this category to "C", but a call to -C would change it. Now such a call will change the -underlying locale of the C category for the program, but the -locale exposed to XS code will remain "C". There is an API under -development for those relatively few modules that need to use the -underlying locale. This API will be nailed down during the course of -developing v5.21. Send email to L for -guidance. +Experimental support for ops in the optree to be able to locate their +parent, if any. A general-purpose function, C<< op_sibling_splice() >> +allows for general manipulating an C<< op_sibling >> chain. The last op +in such a chain is now marked with the field C<< op_lastsib >>. -=item * +A new build define, C<< -DPERL_OP_PARENT >> has been added; if +given, it forces the core to use C<< op_lastsib >> to detect the +last sibling in a chain, freeing the last C<< op_sibling >> pointer, +which then points back to the parent (instead of being C<< NULL >>). -A new macro L|perlapi/isUTF8_CHAR> has been written which -efficiently determines if the string given by its parameters begins -with a well-formed UTF-8 encoded character. +A C-level C<< op_parent() >> function, and a C<< B >> C<< parent() >> method +have been added; under a default build, they return C<< NULL >>, but when +C<< -DPERL_OP_PARENT >> has been set, they return the parent of the current op. =back @@ -892,107 +293,41 @@ with a well-formed UTF-8 encoded character. =item * -index() and rindex() no longer crash when used on strings over 2GB in -size. -L<[perl #121562]|https://rt.perl.org/Ticket/Display.html?id=121562>. - -=item * - -A small previously intentional memory leak in PERL_SYS_INIT/PERL_SYS_INIT3 on -Win32 builds was fixed. This might affect embedders who repeatedly create and -destroy perl engines within the same process. - -=item * - -C now returns the data for the program's underlying -locale even when called from outside the scope of S>. - -=item * - -C now works properly on platforms which don't have -C and/or C, or for which Perl has been compiled -to disregard either or both of these locale categories. In such -circumstances, there are now no entries for the corresponding values in -the hash returned by C. +C<< s///e >> on tainted utf8 strings got C<< pos() >> messed up. This bug, +introduced in 5.20, is now fixed. [RT #122148] =item * -C now marks appropriately the values it returns as -UTF-8 or not. Previously they were always returned as a bytes, even if -they were supposed to be encoded as UTF-8. - -=item * - -On Microsoft Windows, within the scope of C>, the following -POSIX character classes gave results for many locales that did not -conform to the POSIX standard: -C<[[:alnum:]]>, -C<[[:alpha:]]>, -C<[[:blank:]]>, -C<[[:digit:]]>, -C<[[:graph:]]>, -C<[[:lower:]]>, -C<[[:print:]]>, -C<[[:punct:]]>, -C<[[:upper:]]>, -C<[[:word:]]>, -and -C<[[:xdigit:]]>. -These are because the underlying Microsoft implementation does not -follow the standard. Perl now takes special precautions to correct for -this. - -=item * - -Many issues have been detected by L and -fixed. - -=item * - -system() and friends should now work properly on more Android builds. - -Due to an oversight, the value specified through -Dtargetsh to Configure -would end up being ignored by some of the build process. This caused perls -cross-compiled for Android to end up with defective versions of system(), -exec() and backticks: the commands would end up looking for C -instead of C, and so would fail for the vast majority -of devices, leaving C<$!> as C. +A non-word boundary in a regular expression (C<< \B >>) did not always +match the end of the string; in particular C<< q{} =~ /\B/ >> did not +match. This bug, introduced in perl 5.14, is now fixed. [RT #122090] =item * -C, -C, -and -C -now work. Previously it was impossible to escape these three -left-characters with a backslash within a regular expression pattern -where otherwise they would be considered metacharacters, and the pattern -opening delimiter was the character, and the closing delimiter was its -mirror character. +C<< " P" =~ /(?=.*P)P/ >> should match, but did not. This is now fixed. +[RT #122171]. =back =head1 Acknowledgements -Perl 5.21.1 represents approximately 3 weeks of development since Perl 5.21.0 -and contains approximately 240,000 lines of changes across 680 files from 37 +Perl 5.21.2 represents approximately 4 weeks of development since Perl 5.21.1 +and contains approximately 11,000 lines of changes across 220 files from 27 authors. Excluding auto-generated files, documentation and release tools, there were -approximately 150,000 lines of changes to 420 .pm, .t, .c and .h files. +approximately 5,700 lines of changes to 140 .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.21.1: - -Alex Solovey, Andrew Fresh, Andy Dougherty, Brian Fraser, Chris 'BinGOs' -Williams, Craig A. Berry, Dagfinn Ilmari MannsÃ¥ker, Daniel Dragan, Darin -McBride, David Mitchell, Doug Bell, H.Merijn Brand, James E Keenan, Jarkko -Hietaniemi, kafka, Karen Etheridge, Karl Williamson, Leon Timmermans, Matthew -Horsfall, Michael Bunk, Nicholas Clark, Niels Thykier, Norman Koch, Peter John -Acklam, Pierre Bogossian, Reini Urban, Ricardo Signes, Rob Hoelz, Shlomi Fish, -Smylers, Steffen Müller, Steve Hay, Sullivan Beck, Thomas Sibley, Todd -Rinaldo, Tony Cook, Yves Orton. +improvements that became Perl 5.21.2: + +Aaron Crane, Abhijit Menon-Sen, Abigail, Alexandr Ciornii, brian d foy, Brian +Fraser, Chris 'BinGOs' Williams, Craig A. Berry, Daniel Dragan, David Golden, +David Mitchell, Dmitri Tikhonov, George Greer, H.Merijn Brand, James E Keenan, +Jarkko Hietaniemi, Karen Etheridge, Karl Williamson, Matthew Horsfall, Peter +John Acklam, Peter Martini, Reini Urban, Ricardo Signes, Steve Hay, Tony Cook, +Yves Orton, Ævar Arnfjörð Bjarmason. 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 diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 8bd44ac..be29485 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -186,6 +186,13 @@ point and did not attempt to push this layer. If your program didn't explicitly request the failing operation, it may be the result of the value of the environment variable PERLIO. +=item Argument "%s" treated as 0 in increment (++) + +(W numeric) The indicated string was fed as an argument to the C<++> +operator which expects either a number or a string matching +C. See L for details. + =item charnames alias definitions may not contain a sequence of multiple spaces (F) You defined a character name which had multiple space @@ -529,6 +536,16 @@ encountered an invalid data type. iterate over %ENV, it encountered a logical name or symbol definition which was too long, so it was truncated to the string shown. +=item \C is deprecated in regex; marked by <-- HERE in m/%s/ + +(D deprecated, regexp) The \C character class is deprecated, and will +become a compile-time error in a future release of perl (tentatively +v5.24). This construct allows you to match a single byte of what makes up +a multi-byte single UTF8 character, and breaks encapsulation. It is +currently also very buggy. If you really need to process the individual +bytes, you probably want to convert your string to one where each +underlying byte is stored as a character, with utf8::encode(). + =item Callback called exit (F) A subroutine invoked from an external package via call_sv() @@ -2987,8 +3004,20 @@ separate two digits. =item Missing argument in %s -(W uninitialized) A printf-type format required more arguments than were -supplied. +(W missing) You called a function with fewer arguments than other +arguments you supplied indicated would be needed. + +Currently only emitted when a printf-type format required more +arguments than were supplied, but might be used in the future for +other cases where we can statically determine that arguments to +functions are missing, e.g. for the L function. + +=item Redundant argument in %s + +(W redundant) You called a function with more arguments than other +arguments you supplied indicated would be needed. Currently only +emitted when a printf-type format required fewer arguments than were +supplied, but might be used in the future for e.g. L. =item Missing argument to -%c diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 71f4493..173615b 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -4341,23 +4341,45 @@ X X =for Pod::Functions +5.6.0 declare and assign a package variable (lexical scoping) -C makes a lexical alias to a package variable of the same name in the current -package for use within the current lexical scope. +C makes a lexical alias to a package (i.e. global) variable of the +same name in the current package for use within the current lexical scope. -C has the same scoping rules as C or C, but C only -declares an alias, whereas C or C both declare a variable name and -allocate storage for that name within the current scope. +C has the same scoping rules as C or C, meaning that it is +only valid within a lexical scope. Unlike C and C, which both +declare new (lexical) variables, C only creates an alias to an +existing variable: a package variable of the same name. This means that when C is in effect, C lets you use a package variable without qualifying it with the package name, but only within -the lexical scope of the C declaration. In this way, C differs from -C, which allows use of an unqualified name I within the -affected package, but across scopes. +the lexical scope of the C declaration. + + package Foo; + use strict; + + $Foo::foo = 23; + + { + our $foo; # alias to $Foo::foo + print $foo; # prints 23 + } + + print $Foo::foo; # prints 23 + + print $foo; # ERROR: requires explicit package name + +This works even if the package variable has not been used before, as +package variables spring into existence when first used. + + package Foo; + use strict; + + our $foo = 23; # just like $Foo::foo = 23 + + print $Foo::foo; # prints 23 If more than one variable is listed, the list must be placed in parentheses. - our $foo; our($bar, $baz); An C declaration declares an alias for a package variable that will be visible @@ -4408,6 +4430,9 @@ placeholder, for example to skip assignment of initial values: our ( undef, $min, $hour ) = localtime; +C differs from C, which allows use of an unqualified name +I within the affected package, but across scopes. + =item pack TEMPLATE,LIST X diff --git a/pod/perlguts.pod b/pod/perlguts.pod index 74a7df9..4fe0798 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -159,6 +159,58 @@ decrease, the allocated memory of an SV and that it does not automatically add space for the trailing C byte (perl's own string functions typically do C). +If you want to write to an existing SV's buffer and set its value to a +string, use SvPV_force() or one of its variants to force the SV to be +a PV. This will remove any of various types of non-stringness from +the SV while preserving the content of the SV in the PV. This can be +used, for example, to append data from an API function to a buffer +without extra copying: + + (void)SvPVbyte_force(sv, len); + s = SvGROW(sv, len + needlen + 1); + /* something that modifies up to needlen bytes at s+len, but + modifies newlen bytes + eg. newlen = read(fd, s + len, needlen); + ignoring errors for these examples + */ + s[len + newlen] = '\0'; + SvCUR_set(sv, len + newlen); + SvUTF8_off(sv); + SvSETMAGIC(sv); + +If you already have the data in memory or if you want to keep your +code simple, you can use one of the sv_cat*() variants, such as +sv_catpvn(). If you want to insert anywhere in the string you can use +sv_insert() or sv_insert_flags(). + +If you don't need the existing content of the SV, you can avoid some +copying with: + + sv_setpvn(sv, "", 0); + s = SvGROW(sv, needlen + 1); + /* something that modifies up to needlen bytes at s, but modifies + newlen bytes + eg. newlen = read(fd, s. needlen); + */ + s[newlen] = '\0'; + SvCUR_set(sv, newlen); + SvPOK_only(sv); /* also clears SVf_UTF8 */ + SvSETMAGIC(sv); + +Again, if you already have the data in memory or want to avoid the +complexity of the above, you can use sv_setpvn(). + +If you have a buffer allocated with Newx() and want to set that as the +SV's value, you can use sv_usepvn_flags(). That has some requirements +if you want to avoid perl re-allocating the buffer to fit the trailing +NUL: + + Newx(buf, somesize+1, char); + /* ... fill in buf ... */ + buf[somesize] = '\0'; + sv_usepvn_flags(sv, buf, somesize, SV_SMAGIC | SV_HAS_TRAILING_NUL); + /* buf now belongs to perl, don't release it */ + If you have an SV and want to know what kind of data Perl thinks is stored in it, you can use the following macros to check the type of SV you have. @@ -1905,15 +1957,34 @@ C field but also an C field. The most complex type of op is a C, which has any number of children. In this case, the first child is pointed to by C and the last child by C. The children in between can be found by iteratively -following the C pointer from the first child to the last. +following the C pointer from the first child to the last 9but +see below). -There are also two other op types: a C holds a regular expression, +There are also some other op types: a C holds a regular expression, and has no children, and a C may or may not have children. If the C field is non-zero, it behaves like a C. To complicate matters, if a C is actually a C op after optimization (see L) it will still have children in accordance with its former type. +Finally, there is a C, or logic op. Like a C, this has one +or more children, but it doesn't have an C field: so you have to +follow C and then the C chain itself to find the +last child. Instead it has an C field, which is comparable to +the C field described below, and represents an alternate +execution path. Operators like C, C and C are Cs. Note +that in general, C may not point to any of the direct children +of the C. + +Starting in version 5.21.2, perls built with the experimental +define C<-DPERL_OP_PARENT> add an extra boolean flag for each op, +C. When set, this indicates that this is the last op in an +C chain. This frees up the C field on the last +sibling to point back to the parent op. The macro C wraps +this special behaviour, and always returns NULL on the last sibling. +With this build the C function can be used to find the +parent of any op. + Another way to examine the tree is to use a compiler back-end module, such as L. diff --git a/pod/perlhist.pod b/pod/perlhist.pod index 9b9ab9f..de4737c 100644 --- a/pod/perlhist.pod +++ b/pod/perlhist.pod @@ -533,6 +533,7 @@ the strings?). Ricardo 5.21.0 2014-May-27 The 5.21 development track Matthew H 5.21.1 2014-Jun-20 + Abigail 5.21.2 2014-Jul-20 =head2 SELECTED RELEASE SIZES diff --git a/pod/perlpolicy.pod b/pod/perlpolicy.pod index 8120cd8..7f7befa 100644 --- a/pod/perlpolicy.pod +++ b/pod/perlpolicy.pod @@ -1,3 +1,5 @@ +=encoding utf8 + =head1 NAME perlpolicy - Various and sundry policies and commitments related to the Perl core @@ -82,9 +84,9 @@ the Perl community should expect from Perl's developers: =item * -We "officially" support the two most recent stable release series. 5.12.x -and earlier are now out of support. As of the release of 5.18.0, we will -"officially" end support for Perl 5.14.x, other than providing security +We "officially" support the two most recent stable release series. 5.14.x +and earlier are now out of support. As of the release of 5.20.0, we will +"officially" end support for Perl 5.16.x, other than providing security updates as described below. =item * @@ -260,7 +262,7 @@ acceptable. =item * Acceptable documentation updates are those that correct factual errors, -explain significant bugs or deficiencies in the current implementation, +explain significant bugs or deficiencies in the current implementation, or fix broken markup. =item * @@ -271,7 +273,7 @@ are not acceptable. =item * Patches that fix crashing bugs that do not otherwise change Perl's -functionality or negatively impact performance are acceptable. +functionality or negatively impact performance are acceptable. =item * @@ -286,12 +288,12 @@ releases are acceptable. =item * -Updates to dual-life modules should consist of minimal patches to +Updates to dual-life modules should consist of minimal patches to fix crashing or security issues (as above). =item * -Minimal patches that fix platform-specific test failures or +Minimal patches that fix platform-specific test failures or build or installation issues are acceptable. When these changes are made to dual-life modules for which CPAN is canonical, any changes should be coordinated with the upstream author. @@ -323,7 +325,7 @@ maint branches. Any committer may cherry-pick any commit from blead to a maint branch if they send mail to perl5-porters announcing their intent to cherry-pick -a specific commit along with a rationale for doing so and at least two +a specific commit along with a rationale for doing so and at least two other committers respond to the list giving their assent. (This policy applies to current and former pumpkings, as well as other committers.) @@ -482,6 +484,41 @@ in documentation about how behaviour has changed from previous releases, but, with very few exceptions, documentation isn't "dual-life" -- it doesn't need to fully describe how all old versions used to work. +=head1 STANDARDS OF CONDUCT + +The official forum for the development of perl is the perl5-porters mailing +list, mentioned above, and its bugtracker at rt.perl.org. All participants in +discussion there are expected to adhere to a standard of conduct. + +=over 4 + +=item * + +Always be civil. + +=item * + +Heed the moderators. + +=back + +Civility is simple: stick to the facts while avoiding demeaning remarks and +sarcasm. It is not enough to be factual. You must also be civil. Responding +in kind to incivility is not acceptable. + +If the list moderators tell you that you are not being civil, carefully +consider how your words have appeared before responding in any way. You may +protest, but repeated protest in the face of a repeatedly reaffirmed decision +is not acceptable. + +Unacceptable behavior will result in a public and clearly identified warning. +Repeated unacceptable behavior will result in removal from the mailing list. +The first removal is for one month. Subsequent removals will double in length. +After six months with no warning, a user's ban length is reset. Removals, like +warnings, are public. + +The list of moderators will be public knowledge. At present, it is: +Aaron Crane, Andy Dougherty, Ricardo Signes, Steffen Müller. =head1 CREDITS diff --git a/pod/perlre.pod b/pod/perlre.pod index 1ceff9e..bf439ae 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -1684,7 +1684,7 @@ An example of how this might be used is as follows: /(?(?&NAME_PAT))(?(?&ADDRESS_PAT)) (?(DEFINE) (?....) - (?....) + (?....) )/x Note that capture groups matched inside of recursion are not accessible diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod index 244372c..cea4d50 100644 --- a/pod/perlsyn.pod +++ b/pod/perlsyn.pod @@ -429,6 +429,21 @@ those variables is exactly the C loop (the body of the loop and the control sections). X +As a special case, if the test in the C loop (or the corresponding +C loop) is empty, it is treated as true. That is, both + + for (;;) { + ... + } + +and + + while () { + ... + } + +are treated as infinite loops. + Besides the normal array index looping, C can lend itself to many other interesting applications. Here's one that avoids the problem you get into if you explicitly test for end-of-file on diff --git a/pp.c b/pp.c index 4e2d26a..bc7c0df 100644 --- a/pp.c +++ b/pp.c @@ -54,7 +54,6 @@ static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - PP(pp_stub) { - dVAR; dSP; if (GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef); @@ -65,7 +64,7 @@ PP(pp_stub) PP(pp_padav) { - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 gimme; assert(SvTYPE(TARG) == SVt_PVAV); if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO )) @@ -117,7 +116,7 @@ PP(pp_padav) PP(pp_padhv) { - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 gimme; assert(SvTYPE(TARG) == SVt_PVHV); @@ -154,7 +153,7 @@ PP(pp_padhv) PP(pp_padcv) { - dVAR; dSP; dTARGET; + dSP; dTARGET; assert(SvTYPE(TARG) == SVt_PVCV); XPUSHs(TARG); RETURN; @@ -162,14 +161,14 @@ PP(pp_padcv) PP(pp_introcv) { - dVAR; dTARGET; + dTARGET; SvPADSTALE_off(TARG); return NORMAL; } PP(pp_clonecv) { - dVAR; dTARGET; + dTARGET; MAGIC * const mg = mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG], PERL_MAGIC_proto); @@ -211,7 +210,6 @@ static SV * S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, const bool noinit) { - dVAR; if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv); if (SvROK(sv)) { if (SvAMAGIC(sv)) { @@ -305,7 +303,7 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, PP(pp_rv2gv) { - dVAR; dSP; dTOPss; + dSP; dTOPss; sv = S_rv2gv(aTHX_ sv, PL_op->op_private & OPpDEREF, @@ -324,7 +322,6 @@ GV * Perl_softref2xv(pTHX_ SV *const sv, const char *const what, const svtype type, SV ***spp) { - dVAR; GV *gv; PERL_ARGS_ASSERT_SOFTREF2XV; @@ -367,7 +364,7 @@ Perl_softref2xv(pTHX_ SV *const sv, const char *const what, PP(pp_rv2sv) { - dVAR; dSP; dTOPss; + dSP; dTOPss; GV *gv = NULL; SvGETMAGIC(sv); @@ -415,7 +412,7 @@ PP(pp_rv2sv) PP(pp_av2arylen) { - dVAR; dSP; + dSP; AV * const av = MUTABLE_AV(TOPs); const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; if (lvalue) { @@ -433,7 +430,7 @@ PP(pp_av2arylen) PP(pp_pos) { - dVAR; dSP; dPOPss; + dSP; dPOPss; if (PL_op->op_flags & OPf_MOD || LVRET) { SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */ @@ -459,7 +456,7 @@ PP(pp_pos) PP(pp_rv2cv) { - dVAR; dSP; + dSP; GV *gv; HV *stash_unused; const I32 flags = (PL_op->op_flags & OPf_SPECIAL) @@ -484,7 +481,7 @@ PP(pp_rv2cv) PP(pp_prototype) { - dVAR; dSP; + dSP; CV *cv; HV *stash; GV *gv; @@ -517,7 +514,7 @@ PP(pp_prototype) PP(pp_anoncode) { - dVAR; dSP; + dSP; CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ)); if (CvCLONE(cv)) cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); @@ -528,14 +525,14 @@ PP(pp_anoncode) PP(pp_srefgen) { - dVAR; dSP; + dSP; *SP = refto(*SP); RETURN; } PP(pp_refgen) { - dVAR; dSP; dMARK; + dSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; @@ -554,7 +551,6 @@ PP(pp_refgen) STATIC SV* S_refto(pTHX_ SV *sv) { - dVAR; SV* rv; PERL_ARGS_ASSERT_REFTO; @@ -590,21 +586,26 @@ S_refto(pTHX_ SV *sv) PP(pp_ref) { - dVAR; dSP; dTARGET; - SV * const sv = POPs; + dSP; + SV * const sv = TOPs; SvGETMAGIC(sv); if (!SvROK(sv)) - RETPUSHNO; + SETs(&PL_sv_no); + else { + dTARGET; + SETs(TARG); + /* use the return value that is in a register, its the same as TARG */ + TARG = sv_ref(TARG,SvRV(sv),TRUE); + SvSETMAGIC(TARG); + } - (void)sv_ref(TARG,SvRV(sv),TRUE); - PUSHTARG; - RETURN; + return NORMAL; } PP(pp_bless) { - dVAR; dSP; + dSP; HV *stash; if (MAXARG == 1) @@ -645,7 +646,7 @@ PP(pp_bless) PP(pp_gelem) { - dVAR; dSP; + dSP; SV *sv = POPs; STRLEN len; @@ -724,7 +725,7 @@ PP(pp_gelem) PP(pp_study) { - dVAR; dSP; dPOPss; + dSP; dPOPss; STRLEN len; (void)SvPV(sv, len); @@ -740,7 +741,7 @@ PP(pp_study) PP(pp_trans) { - dVAR; dSP; dTARG; + dSP; dTARG; SV *sv; if (PL_op->op_flags & OPf_STACKED) @@ -770,7 +771,6 @@ PP(pp_trans) static void S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) { - dVAR; STRLEN len; char *s; @@ -934,7 +934,7 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) PP(pp_schop) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const bool chomping = PL_op->op_type == OP_SCHOMP; if (chomping) @@ -946,7 +946,7 @@ PP(pp_schop) PP(pp_chop) { - dVAR; dSP; dMARK; dTARGET; dORIGMARK; + dSP; dMARK; dTARGET; dORIGMARK; const bool chomping = PL_op->op_type == OP_CHOMP; if (chomping) @@ -960,7 +960,7 @@ PP(pp_chop) PP(pp_undef) { - dVAR; dSP; + dSP; SV *sv; if (!PL_op->op_private) { @@ -1069,7 +1069,7 @@ PP(pp_undef) PP(pp_postinc) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const bool inc = PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC; if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))) @@ -1098,7 +1098,7 @@ PP(pp_postinc) PP(pp_pow) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; #ifdef PERL_PRESERVE_IVUV bool is_int = 0; #endif @@ -1265,7 +1265,7 @@ PP(pp_pow) PP(pp_multiply) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; @@ -1387,7 +1387,7 @@ PP(pp_multiply) PP(pp_divide) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; @@ -1507,7 +1507,7 @@ PP(pp_divide) PP(pp_modulo) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric); { UV left = 0; @@ -1634,7 +1634,7 @@ PP(pp_modulo) PP(pp_repeat) { - dVAR; dSP; dATARGET; + dSP; dATARGET; IV count; SV *sv; @@ -1777,7 +1777,7 @@ PP(pp_repeat) PP(pp_subtract) { - dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr; + dSP; dATARGET; bool useleft; SV *svl, *svr; tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; @@ -1896,7 +1896,7 @@ PP(pp_subtract) PP(pp_left_shift) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric); svr = POPs; svl = TOPs; @@ -1916,7 +1916,7 @@ PP(pp_left_shift) PP(pp_right_shift) { - dVAR; dSP; dATARGET; SV *svl, *svr; + dSP; dATARGET; SV *svl, *svr; tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric); svr = POPs; svl = TOPs; @@ -1936,7 +1936,7 @@ PP(pp_right_shift) PP(pp_lt) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric); @@ -1952,7 +1952,7 @@ PP(pp_lt) PP(pp_gt) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric); @@ -1968,7 +1968,7 @@ PP(pp_gt) PP(pp_le) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric); @@ -1984,7 +1984,7 @@ PP(pp_le) PP(pp_ge) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric); @@ -2000,7 +2000,7 @@ PP(pp_ge) PP(pp_ne) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric); @@ -2023,8 +2023,6 @@ PP(pp_ne) I32 Perl_do_ncmp(pTHX_ SV* const left, SV * const right) { - dVAR; - PERL_ARGS_ASSERT_DO_NCMP; #ifdef PERL_PRESERVE_IVUV /* Fortunately it seems NaN isn't IOK */ @@ -2090,7 +2088,7 @@ Perl_do_ncmp(pTHX_ SV* const left, SV * const right) PP(pp_ncmp) { - dVAR; dSP; + dSP; SV *left, *right; I32 value; tryAMAGICbin_MG(ncmp_amg, AMGf_numeric); @@ -2109,7 +2107,7 @@ PP(pp_ncmp) PP(pp_sle) { - dVAR; dSP; + dSP; int amg_type = sle_amg; int multiplier = 1; @@ -2151,7 +2149,7 @@ PP(pp_sle) PP(pp_seq) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(seq_amg, AMGf_set); { dPOPTOPssrl; @@ -2162,7 +2160,7 @@ PP(pp_seq) PP(pp_sne) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(sne_amg, AMGf_set); { dPOPTOPssrl; @@ -2173,7 +2171,7 @@ PP(pp_sne) PP(pp_scmp) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICbin_MG(scmp_amg, 0); { dPOPTOPssrl; @@ -2191,7 +2189,7 @@ PP(pp_scmp) PP(pp_bit_and) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(band_amg, AMGf_assign); { dPOPTOPssrl; @@ -2219,7 +2217,7 @@ PP(pp_bit_and) PP(pp_bit_or) { - dVAR; dSP; dATARGET; + dSP; dATARGET; const int op_type = PL_op->op_type; tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign); @@ -2276,7 +2274,7 @@ S_negate_string(pTHX) PP(pp_negate) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(neg_amg, AMGf_numeric); if (S_negate_string(aTHX)) return NORMAL; { @@ -2320,7 +2318,7 @@ PP(pp_negate) PP(pp_not) { - dVAR; dSP; + dSP; tryAMAGICun_MG(not_amg, AMGf_set); *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp)); return NORMAL; @@ -2328,7 +2326,7 @@ PP(pp_not) PP(pp_complement) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(compl_amg, AMGf_numeric); { dTOPss; @@ -2429,7 +2427,7 @@ PP(pp_complement) PP(pp_i_multiply) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(mult_amg, AMGf_assign); { dPOPTOPiirl_nomg; @@ -2441,7 +2439,7 @@ PP(pp_i_multiply) PP(pp_i_divide) { IV num; - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(div_amg, AMGf_assign); { dPOPTOPssrl; @@ -2468,7 +2466,7 @@ PP(pp_i_modulo) #endif { /* This is the vanilla old i_modulo. */ - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(modulo_amg, AMGf_assign); { dPOPTOPiirl_nomg; @@ -2491,7 +2489,7 @@ PP(pp_i_modulo_1) /* This is the i_modulo with the workaround for the _moddi3 bug * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). * See below for pp_i_modulo. */ - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(modulo_amg, AMGf_assign); { dPOPTOPiirl_nomg; @@ -2552,7 +2550,7 @@ PP(pp_i_modulo) PP(pp_i_add) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(add_amg, AMGf_assign); { dPOPTOPiirl_ul_nomg; @@ -2563,7 +2561,7 @@ PP(pp_i_add) PP(pp_i_subtract) { - dVAR; dSP; dATARGET; + dSP; dATARGET; tryAMAGICbin_MG(subtr_amg, AMGf_assign); { dPOPTOPiirl_ul_nomg; @@ -2574,7 +2572,7 @@ PP(pp_i_subtract) PP(pp_i_lt) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(lt_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2585,7 +2583,7 @@ PP(pp_i_lt) PP(pp_i_gt) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(gt_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2596,7 +2594,7 @@ PP(pp_i_gt) PP(pp_i_le) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(le_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2607,7 +2605,7 @@ PP(pp_i_le) PP(pp_i_ge) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(ge_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2618,7 +2616,7 @@ PP(pp_i_ge) PP(pp_i_eq) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(eq_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2629,7 +2627,7 @@ PP(pp_i_eq) PP(pp_i_ne) { - dVAR; dSP; + dSP; tryAMAGICbin_MG(ne_amg, AMGf_set); { dPOPTOPiirl_nomg; @@ -2640,7 +2638,7 @@ PP(pp_i_ne) PP(pp_i_ncmp) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICbin_MG(ncmp_amg, 0); { dPOPTOPiirl_nomg; @@ -2659,7 +2657,7 @@ PP(pp_i_ncmp) PP(pp_i_negate) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(neg_amg, 0); if (S_negate_string(aTHX)) return NORMAL; { @@ -2674,7 +2672,7 @@ PP(pp_i_negate) PP(pp_atan2) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICbin_MG(atan2_amg, 0); { dPOPTOPnnrl_nomg; @@ -2685,7 +2683,7 @@ PP(pp_atan2) PP(pp_sin) { - dVAR; dSP; dTARGET; + dSP; dTARGET; int amg_type = sin_amg; const char *neg_report = NULL; NV (*func)(NV) = Perl_sin; @@ -2742,7 +2740,6 @@ PP(pp_sin) PP(pp_rand) { - dVAR; if (!PL_srand_called) { (void)seedDrand01((Rand_seed_t)seed()); PL_srand_called = TRUE; @@ -2777,7 +2774,7 @@ PP(pp_rand) PP(pp_srand) { - dVAR; dSP; dTARGET; + dSP; dTARGET; UV anum; if (MAXARG >= 1 && (TOPs || POPs)) { @@ -2815,7 +2812,7 @@ PP(pp_srand) PP(pp_int) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(int_amg, AMGf_numeric); { SV * const sv = TOPs; @@ -2857,7 +2854,7 @@ PP(pp_int) PP(pp_abs) { - dVAR; dSP; dTARGET; + dSP; dTARGET; tryAMAGICun_MG(abs_amg, AMGf_numeric); { SV * const sv = TOPs; @@ -2897,7 +2894,7 @@ PP(pp_abs) PP(pp_oct) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const char *tmps; I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; STRLEN len; @@ -2944,7 +2941,7 @@ PP(pp_oct) PP(pp_length) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV * const sv = TOPs; SvGETMAGIC(sv); @@ -2972,16 +2969,15 @@ PP(pp_length) always be true for an explicit 0. */ bool -Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv, - bool pos1_is_uv, IV len_iv, - bool len_is_uv, STRLEN *posp, - STRLEN *lenp) +Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv, + bool pos1_is_uv, IV len_iv, + bool len_is_uv, STRLEN *posp, + STRLEN *lenp) { IV pos2_iv; int pos2_is_uv; PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS; - PERL_UNUSED_CONTEXT; if (!pos1_is_uv && pos1_iv < 0 && curlen) { pos1_is_uv = curlen-1 > ~(UV)pos1_iv; @@ -3037,7 +3033,7 @@ Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv, PP(pp_substr) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV *sv; STRLEN curlen; STRLEN utf8_curlen; @@ -3176,7 +3172,7 @@ bound_fail: PP(pp_vec) { - dVAR; dSP; + dSP; const IV size = POPi; const IV offset = POPi; SV * const src = POPs; @@ -3204,7 +3200,7 @@ PP(pp_vec) PP(pp_index) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV *big; SV *little; SV *temp = NULL; @@ -3321,7 +3317,7 @@ PP(pp_index) PP(pp_sprintf) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; SvTAINTED_off(TARG); do_sprintf(TARG, SP-MARK, MARK+1); TAINT_IF(SvTAINTED(TARG)); @@ -3332,7 +3328,7 @@ PP(pp_sprintf) PP(pp_ord) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV *argsv = POPs; STRLEN len; @@ -3354,7 +3350,7 @@ PP(pp_ord) PP(pp_chr) { - dVAR; dSP; dTARGET; + dSP; dTARGET; char *tmps; UV value; SV *top = POPs; @@ -3422,7 +3418,7 @@ PP(pp_chr) PP(pp_crypt) { #ifdef HAS_CRYPT - dVAR; dSP; dTARGET; + dSP; dTARGET; dPOPTOPssrl; STRLEN len; const char *tmps = SvPV_const(left, len); @@ -3478,7 +3474,6 @@ PP(pp_ucfirst) * take the source and change that one character and store it back, but not * if read-only etc, or if the length changes */ - dVAR; dSP; SV *source = TOPs; STRLEN slen; /* slen is the byte length of the whole SV. */ @@ -3731,7 +3726,6 @@ PP(pp_ucfirst) of the three tight loops. There is less and less commonality though */ PP(pp_uc) { - dVAR; dSP; SV *source = TOPs; STRLEN len; @@ -3986,7 +3980,6 @@ PP(pp_uc) PP(pp_lc) { - dVAR; dSP; SV *source = TOPs; STRLEN len; @@ -4113,7 +4106,7 @@ PP(pp_lc) PP(pp_quotemeta) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV * const sv = TOPs; STRLEN len; const char *s = SvPV_const(sv,len); @@ -4188,7 +4181,6 @@ PP(pp_quotemeta) PP(pp_fc) { - dVAR; dTARGET; dSP; SV *source = TOPs; @@ -4353,7 +4345,7 @@ PP(pp_fc) PP(pp_aslice) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; AV *const av = MUTABLE_AV(POPs); const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); @@ -4417,7 +4409,7 @@ PP(pp_aslice) PP(pp_kvaslice) { - dVAR; dSP; dMARK; + dSP; dMARK; AV *const av = MUTABLE_AV(POPs); I32 lval = (PL_op->op_flags & OPf_MOD); SSize_t items = SP - MARK; @@ -4463,7 +4455,6 @@ PP(pp_kvaslice) /* Smart dereferencing for keys, values and each */ PP(pp_rkeys) { - dVAR; dSP; dPOPss; @@ -4501,7 +4492,6 @@ PP(pp_rkeys) PP(pp_aeach) { - dVAR; dSP; AV *array = MUTABLE_AV(POPs); const I32 gimme = GIMME_V; @@ -4527,7 +4517,6 @@ PP(pp_aeach) PP(pp_akeys) { - dVAR; dSP; AV *array = MUTABLE_AV(POPs); const I32 gimme = GIMME_V; @@ -4563,7 +4552,6 @@ PP(pp_akeys) PP(pp_each) { - dVAR; dSP; HV * hash = MUTABLE_HV(POPs); HE *entry; @@ -4596,7 +4584,6 @@ PP(pp_each) STATIC OP * S_do_delete_local(pTHX) { - dVAR; dSP; const I32 gimme = GIMME_V; const MAGIC *mg; @@ -4707,7 +4694,6 @@ S_do_delete_local(pTHX) PP(pp_delete) { - dVAR; dSP; I32 gimme; I32 discard; @@ -4773,7 +4759,6 @@ PP(pp_delete) PP(pp_exists) { - dVAR; dSP; SV *tmpsv; HV *hv; @@ -4808,7 +4793,7 @@ PP(pp_exists) PP(pp_hslice) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; HV * const hv = MUTABLE_HV(POPs); const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); const bool localizing = PL_op->op_private & OPpLVAL_INTRO; @@ -4865,7 +4850,7 @@ PP(pp_hslice) PP(pp_kvhslice) { - dVAR; dSP; dMARK; + dSP; dMARK; HV * const hv = MUTABLE_HV(POPs); I32 lval = (PL_op->op_flags & OPf_MOD); SSize_t items = SP - MARK; @@ -4916,7 +4901,6 @@ PP(pp_kvhslice) PP(pp_list) { - dVAR; I32 markidx = POPMARK; if (GIMME != G_ARRAY) { SV **mark = PL_stack_base + markidx; @@ -4933,7 +4917,6 @@ PP(pp_list) PP(pp_lslice) { - dVAR; dSP; SV ** const lastrelem = PL_stack_sp; SV ** const lastlelem = PL_stack_base + POPMARK; @@ -4987,7 +4970,7 @@ PP(pp_lslice) PP(pp_anonlist) { - dVAR; dSP; dMARK; + dSP; dMARK; const I32 items = SP - MARK; SV * const av = MUTABLE_SV(av_make(items, MARK+1)); SP = MARK; @@ -4998,7 +4981,7 @@ PP(pp_anonlist) PP(pp_anonhash) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; HV* const hv = newHV(); SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL ? newRV_noinc(MUTABLE_SV(hv)) @@ -5059,7 +5042,7 @@ S_deref_plain_array(pTHX_ AV *ary) PP(pp_splice) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; int num_args = (SP - MARK); AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); SV **src; @@ -5269,7 +5252,7 @@ PP(pp_splice) PP(pp_push) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); @@ -5307,7 +5290,6 @@ PP(pp_push) PP(pp_shift) { - dVAR; dSP; AV * const av = PL_op->op_flags & OPf_SPECIAL ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs)); @@ -5322,7 +5304,7 @@ PP(pp_shift) PP(pp_unshift) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK)); const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied); @@ -5352,7 +5334,7 @@ PP(pp_unshift) PP(pp_reverse) { - dVAR; dSP; dMARK; + dSP; dMARK; if (GIMME == G_ARRAY) { if (PL_op->op_private & OPpREVERSE_INPLACE) { @@ -5483,7 +5465,7 @@ PP(pp_reverse) PP(pp_split) { - dVAR; dSP; dTARG; + dSP; dTARG; AV *ary; IV limit = POPi; /* note, negative is forever */ SV * const sv = POPs; @@ -5927,7 +5909,6 @@ PP(pp_once) PP(pp_lock) { - dVAR; dSP; dTOPss; SV *retsv = sv; @@ -5943,7 +5924,6 @@ PP(pp_lock) PP(unimplemented_op) { - dVAR; const Optype op_type = PL_op->op_type; /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope with out of range op numbers - it only "special" cases op_custom. diff --git a/pp_ctl.c b/pp_ctl.c index 71542db..7d098b7 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -40,7 +40,6 @@ PP(pp_wantarray) { - dVAR; dSP; I32 cxix; const PERL_CONTEXT *cx; @@ -68,14 +67,12 @@ PP(pp_wantarray) PP(pp_regcreset) { - dVAR; TAINT_NOT; return NORMAL; } PP(pp_regcomp) { - dVAR; dSP; PMOP *pm = (PMOP*)cLOGOP->op_other; SV **args; @@ -191,7 +188,6 @@ PP(pp_regcomp) PP(pp_substcont) { - dVAR; dSP; PERL_CONTEXT *cx = &cxstack[cxstack_ix]; PMOP * const pm = (PMOP*) cLOGOP->op_other; @@ -319,8 +315,8 @@ PP(pp_substcont) if (!(mg = mg_find_mglob(sv))) { mg = sv_magicext_mglob(sv); } - assert(SvPOK(dstr)); - MgBYTEPOS_set(mg, sv, SvPVX(dstr), m - orig); + assert(SvPOK(sv)); + MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig); } if (old != rx) (void)ReREFCNT_inc(rx); @@ -457,7 +453,7 @@ S_rxres_free(pTHX_ void **rsp) PP(pp_formline) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; SV * const tmpForm = *++MARK; SV *formsv; /* contains text of original format */ U32 *fpc; /* format ops program counter */ @@ -837,11 +833,14 @@ PP(pp_formline) } /* Formats aren't yet marked for locales, so assume "yes". */ { + Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)); + int len; DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); - arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK); + arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK); /* we generate fmt ourselves so it is safe */ GCC_DIAG_IGNORE(-Wformat-nonliteral); - my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value); + len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value); + PERL_MY_SNPRINTF_POST_GUARD(len, max); GCC_DIAG_RESTORE; RESTORE_LC_NUMERIC(); } @@ -916,7 +915,7 @@ PP(pp_formline) PP(pp_grepstart) { - dVAR; dSP; + dSP; SV *src; if (PL_stack_base + *PL_markstack_ptr == SP) { @@ -958,7 +957,7 @@ PP(pp_grepstart) PP(pp_mapwhile) { - dVAR; dSP; + dSP; const I32 gimme = GIMME_V; I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ I32 count; @@ -1110,7 +1109,6 @@ PP(pp_mapwhile) PP(pp_range) { - dVAR; if (GIMME == G_ARRAY) return NORMAL; if (SvTRUEx(PAD_SV(PL_op->op_targ))) @@ -1121,7 +1119,6 @@ PP(pp_range) PP(pp_flip) { - dVAR; dSP; if (GIMME == G_ARRAY) { @@ -1176,7 +1173,7 @@ PP(pp_flip) PP(pp_flop) { - dVAR; dSP; + dSP; if (GIMME == G_ARRAY) { dPOPPOPssrl; @@ -1280,7 +1277,6 @@ static const char * const context_name[] = { STATIC I32 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags) { - dVAR; I32 i; PERL_ARGS_ASSERT_DOPOPTOLABEL; @@ -1335,7 +1331,6 @@ S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags) I32 Perl_dowantarray(pTHX) { - dVAR; const I32 gimme = block_gimme(); return (gimme == G_VOID) ? G_SCALAR : gimme; } @@ -1343,7 +1338,6 @@ Perl_dowantarray(pTHX) I32 Perl_block_gimme(pTHX) { - dVAR; const I32 cxix = dopoptosub(cxstack_ix); if (cxix < 0) return G_VOID; @@ -1364,7 +1358,6 @@ Perl_block_gimme(pTHX) I32 Perl_is_lvalue_sub(pTHX) { - dVAR; const I32 cxix = dopoptosub(cxstack_ix); assert(cxix >= 0); /* We should only be called from inside subs */ @@ -1378,7 +1371,6 @@ Perl_is_lvalue_sub(pTHX) I32 Perl_was_lvalue_sub(pTHX) { - dVAR; const I32 cxix = dopoptosub(cxstack_ix-1); assert(cxix >= 0); /* We should only be called from inside subs */ @@ -1391,7 +1383,6 @@ Perl_was_lvalue_sub(pTHX) STATIC I32 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) { - dVAR; I32 i; PERL_ARGS_ASSERT_DOPOPTOSUB_AT; @@ -1424,7 +1415,6 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) STATIC I32 S_dopoptoeval(pTHX_ I32 startingblock) { - dVAR; I32 i; for (i = startingblock; i >= 0; i--) { const PERL_CONTEXT *cx = &cxstack[i]; @@ -1442,7 +1432,6 @@ S_dopoptoeval(pTHX_ I32 startingblock) STATIC I32 S_dopoptoloop(pTHX_ I32 startingblock) { - dVAR; I32 i; for (i = startingblock; i >= 0; i--) { const PERL_CONTEXT * const cx = &cxstack[i]; @@ -1472,7 +1461,6 @@ S_dopoptoloop(pTHX_ I32 startingblock) STATIC I32 S_dopoptogiven(pTHX_ I32 startingblock) { - dVAR; I32 i; for (i = startingblock; i >= 0; i--) { const PERL_CONTEXT *cx = &cxstack[i]; @@ -1500,7 +1488,6 @@ S_dopoptogiven(pTHX_ I32 startingblock) STATIC I32 S_dopoptowhen(pTHX_ I32 startingblock) { - dVAR; I32 i; for (i = startingblock; i >= 0; i--) { const PERL_CONTEXT *cx = &cxstack[i]; @@ -1518,7 +1505,6 @@ S_dopoptowhen(pTHX_ I32 startingblock) void Perl_dounwind(pTHX_ I32 cxix) { - dVAR; I32 optype; if (!PL_curstackinfo) /* can happen if die during thread cloning */ @@ -1560,8 +1546,6 @@ Perl_dounwind(pTHX_ I32 cxix) void Perl_qerror(pTHX_ SV *err) { - dVAR; - PERL_ARGS_ASSERT_QERROR; if (PL_in_eval) { @@ -1583,7 +1567,6 @@ Perl_qerror(pTHX_ SV *err) void Perl_die_unwind(pTHX_ SV *msv) { - dVAR; SV *exceptsv = sv_mortalcopy(msv); U8 in_eval = PL_in_eval; PERL_ARGS_ASSERT_DIE_UNWIND; @@ -1705,7 +1688,7 @@ Perl_die_unwind(pTHX_ SV *msv) PP(pp_xor) { - dVAR; dSP; dPOPTOPssrl; + dSP; dPOPTOPssrl; if (SvTRUE(left) != SvTRUE(right)) RETSETYES; else @@ -1777,7 +1760,6 @@ Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) PP(pp_caller) { - dVAR; dSP; const PERL_CONTEXT *cx; const PERL_CONTEXT *dbcx; @@ -1829,7 +1811,7 @@ PP(pp_caller) PUSHTARG; } mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); - lcop = closest_cop(cx->blk_oldcop, cx->blk_oldcop->op_sibling, + lcop = closest_cop(cx->blk_oldcop, OP_SIBLING(cx->blk_oldcop), cx->blk_sub.retop, TRUE); if (!lcop) lcop = cx->blk_oldcop; @@ -1937,7 +1919,6 @@ PP(pp_caller) PP(pp_reset) { - dVAR; dSP; const char * tmps; STRLEN len = 0; @@ -1954,7 +1935,6 @@ PP(pp_reset) PP(pp_dbstate) { - dVAR; PL_curcop = (COP*)PL_op; TAINT_NOT; /* Each statement is presumed innocent */ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; @@ -2067,7 +2047,7 @@ S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, PP(pp_enter) { - dVAR; dSP; + dSP; PERL_CONTEXT *cx; I32 gimme = GIMME_V; @@ -2081,7 +2061,7 @@ PP(pp_enter) PP(pp_leave) { - dVAR; dSP; + dSP; PERL_CONTEXT *cx; SV **newsp; PMOP *newpm; @@ -2108,7 +2088,7 @@ PP(pp_leave) PP(pp_enteriter) { - dVAR; dSP; dMARK; + dSP; dMARK; PERL_CONTEXT *cx; const I32 gimme = GIMME_V; void *itervar; /* location of the iteration variable */ @@ -2231,7 +2211,7 @@ PP(pp_enteriter) PP(pp_enterloop) { - dVAR; dSP; + dSP; PERL_CONTEXT *cx; const I32 gimme = GIMME_V; @@ -2247,7 +2227,7 @@ PP(pp_enterloop) PP(pp_leaveloop) { - dVAR; dSP; + dSP; PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -2385,7 +2365,7 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, PP(pp_return) { - dVAR; dSP; dMARK; + dSP; dMARK; PERL_CONTEXT *cx; bool popsub2 = FALSE; bool clear_errsv = FALSE; @@ -2526,7 +2506,7 @@ PP(pp_return) * pp_return */ PP(pp_leavesublv) { - dVAR; dSP; + dSP; SV **newsp; PMOP *newpm; I32 gimme; @@ -2555,7 +2535,6 @@ PP(pp_leavesublv) static I32 S_unwind_loop(pTHX_ const char * const opname) { - dVAR; I32 cxix; if (PL_op->op_flags & OPf_SPECIAL) { cxix = dopoptoloop(cxstack_ix); @@ -2594,7 +2573,6 @@ S_unwind_loop(pTHX_ const char * const opname) PP(pp_last) { - dVAR; PERL_CONTEXT *cx; I32 pop2 = 0; I32 gimme; @@ -2661,7 +2639,6 @@ PP(pp_last) PP(pp_next) { - dVAR; PERL_CONTEXT *cx; const I32 inner = PL_scopestack_ix; @@ -2679,7 +2656,6 @@ PP(pp_next) PP(pp_redo) { - dVAR; const I32 cxix = S_unwind_loop(aTHX_ "redo"); PERL_CONTEXT *cx; I32 oldsave; @@ -2704,7 +2680,6 @@ PP(pp_redo) STATIC OP * S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit) { - dVAR; OP **ops = opstack; static const char* const too_deep = "Target of goto is too deeply nested"; @@ -2726,7 +2701,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac if (o->op_flags & OPf_KIDS) { OP *kid; /* First try all the kids at this level, since that's likeliest. */ - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { + for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) { if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { STRLEN kid_label_len; U32 kid_label_flags; @@ -2746,7 +2721,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac return kid; } } - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { + for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) { if (kid == PL_lastgotoprobe) continue; if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { @@ -3032,13 +3007,13 @@ PP(pp_goto) /* also pp_dump */ case CXt_LOOP_PLAIN: case CXt_GIVEN: case CXt_WHEN: - gotoprobe = cx->blk_oldcop->op_sibling; + gotoprobe = OP_SIBLING(cx->blk_oldcop); break; case CXt_SUBST: continue; case CXt_BLOCK: if (ix) { - gotoprobe = cx->blk_oldcop->op_sibling; + gotoprobe = OP_SIBLING(cx->blk_oldcop); in_block = TRUE; } else gotoprobe = PL_main_root; @@ -3060,14 +3035,17 @@ PP(pp_goto) /* also pp_dump */ break; } if (gotoprobe) { + OP *sibl1, *sibl2; + retop = dofindlabel(gotoprobe, label, label_len, label_flags, enterops, enterops + GOTO_DEPTH); if (retop) break; - if (gotoprobe->op_sibling && - gotoprobe->op_sibling->op_type == OP_UNSTACK && - gotoprobe->op_sibling->op_sibling) { - retop = dofindlabel(gotoprobe->op_sibling->op_sibling, + if ( (sibl1 = OP_SIBLING(gotoprobe)) && + sibl1->op_type == OP_UNSTACK && + (sibl2 = OP_SIBLING(sibl1))) + { + retop = dofindlabel(sibl2, label, label_len, label_flags, enterops, enterops + GOTO_DEPTH); if (retop) @@ -3146,7 +3124,6 @@ PP(pp_goto) /* also pp_dump */ PP(pp_exit) { - dVAR; dSP; I32 anum; @@ -3215,7 +3192,6 @@ establish a local jmpenv to handle exception traps. STATIC OP * S_docatch(pTHX_ OP *o) { - dVAR; int ret; OP * const oldop = PL_op; dJMPENV; @@ -3277,7 +3253,6 @@ Perl_find_runcv(pTHX_ U32 *db_seqp) CV * Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) { - dVAR; PERL_SI *si; int level = 0; @@ -3370,7 +3345,7 @@ S_try_yyparse(pTHX_ int gramtype) STATIC bool S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) { - dVAR; dSP; + dSP; OP * const saveop = PL_op; bool clear_hints = saveop->op_type != OP_ENTEREVAL; COP * const oldcurcop = PL_curcop; @@ -3679,7 +3654,7 @@ S_path_is_searchable(const char *name) PP(pp_require) { - dVAR; dSP; + dSP; PERL_CONTEXT *cx; SV *sv; const char *name; @@ -4165,7 +4140,6 @@ PP(pp_require) PP(pp_hintseval) { - dVAR; dSP; mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv)))); RETURN; @@ -4174,7 +4148,7 @@ PP(pp_hintseval) PP(pp_entereval) { - dVAR; dSP; + dSP; PERL_CONTEXT *cx; SV *sv; const I32 gimme = GIMME_V; @@ -4302,7 +4276,7 @@ PP(pp_entereval) PP(pp_leaveeval) { - dVAR; dSP; + dSP; SV **newsp; PMOP *newpm; I32 gimme; @@ -4399,7 +4373,6 @@ Perl_create_eval_scope(pTHX_ U32 flags) PP(pp_entertry) { - dVAR; PERL_CONTEXT * const cx = create_eval_scope(0); cx->blk_eval.retop = cLOGOP->op_other->op_next; return DOCATCH(PL_op->op_next); @@ -4407,7 +4380,7 @@ PP(pp_entertry) PP(pp_leavetry) { - dVAR; dSP; + dSP; SV **newsp; PMOP *newpm; I32 gimme; @@ -4431,7 +4404,7 @@ PP(pp_leavetry) PP(pp_entergiven) { - dVAR; dSP; + dSP; PERL_CONTEXT *cx; const I32 gimme = GIMME_V; @@ -4456,7 +4429,7 @@ PP(pp_entergiven) PP(pp_leavegiven) { - dVAR; dSP; + dSP; PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -4479,7 +4452,6 @@ PP(pp_leavegiven) STATIC PMOP * S_make_matcher(pTHX_ REGEXP *re) { - dVAR; PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED); PERL_ARGS_ASSERT_MAKE_MATCHER; @@ -4495,7 +4467,6 @@ S_make_matcher(pTHX_ REGEXP *re) STATIC bool S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) { - dVAR; dSP; PERL_ARGS_ASSERT_MATCHER_MATCHES_SV; @@ -4511,8 +4482,6 @@ S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) STATIC void S_destroy_matcher(pTHX_ PMOP *matcher) { - dVAR; - PERL_ARGS_ASSERT_DESTROY_MATCHER; PERL_UNUSED_ARG(matcher); @@ -4533,7 +4502,6 @@ PP(pp_smartmatch) STATIC OP * S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) { - dVAR; dSP; bool object_on_left = FALSE; @@ -5005,7 +4973,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) PP(pp_enterwhen) { - dVAR; dSP; + dSP; PERL_CONTEXT *cx; const I32 gimme = GIMME_V; @@ -5029,7 +4997,7 @@ PP(pp_enterwhen) PP(pp_leavewhen) { - dVAR; dSP; + dSP; I32 cxix; PERL_CONTEXT *cx; I32 gimme; @@ -5077,7 +5045,7 @@ PP(pp_leavewhen) PP(pp_continue) { - dVAR; dSP; + dSP; I32 cxix; PERL_CONTEXT *cx; I32 gimme; @@ -5105,7 +5073,6 @@ PP(pp_continue) PP(pp_break) { - dVAR; I32 cxix; PERL_CONTEXT *cx; @@ -5408,7 +5375,6 @@ S_num_overflow(NV value, I32 fldsize, I32 frcsize) static I32 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) { - dVAR; SV * const datasv = FILTER_DATA(idx); const int filter_has_file = IoLINES(datasv); SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv)); diff --git a/pp_hot.c b/pp_hot.c index fc24abf..12a22cb 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -39,7 +39,6 @@ PP(pp_const) { - dVAR; dSP; XPUSHs(cSVOP_sv); RETURN; @@ -47,7 +46,6 @@ PP(pp_const) PP(pp_nextstate) { - dVAR; PL_curcop = (COP*)PL_op; TAINT_NOT; /* Each statement is presumed innocent */ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; @@ -58,7 +56,6 @@ PP(pp_nextstate) PP(pp_gvsv) { - dVAR; dSP; EXTEND(SP,1); if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) @@ -70,21 +67,19 @@ PP(pp_gvsv) PP(pp_null) { - dVAR; return NORMAL; } /* This is sometimes called directly by pp_coreargs and pp_grepstart. */ PP(pp_pushmark) { - dVAR; PUSHMARK(PL_stack_sp); return NORMAL; } PP(pp_stringify) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV * const sv = TOPs; SETs(TARG); sv_copypv(TARG, sv); @@ -95,14 +90,13 @@ PP(pp_stringify) PP(pp_gv) { - dVAR; dSP; + dSP; XPUSHs(MUTABLE_SV(cGVOP_gv)); RETURN; } PP(pp_and) { - dVAR; PERL_ASYNC_CHECK(); { /* SP is not used to remove a variable that is saved across the @@ -123,7 +117,7 @@ PP(pp_and) PP(pp_sassign) { - dVAR; dSP; + dSP; /* sassign keeps its args in the optree traditionally backwards. So we pop them differently. */ @@ -228,7 +222,7 @@ PP(pp_sassign) PP(pp_cond_expr) { - dVAR; dSP; + dSP; PERL_ASYNC_CHECK(); if (SvTRUEx(POPs)) RETURNOP(cLOGOP->op_other); @@ -238,7 +232,6 @@ PP(pp_cond_expr) PP(pp_unstack) { - dVAR; PERL_ASYNC_CHECK(); TAINT_NOT; /* Each statement is presumed innocent */ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; @@ -252,7 +245,7 @@ PP(pp_unstack) PP(pp_concat) { - dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign); + dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign); { dPOPTOPssrl; bool lbyte; @@ -357,7 +350,7 @@ S_pushav(pTHX_ AV* const av) PP(pp_padrange) { - dVAR; dSP; + dSP; PADOFFSET base = PL_op->op_targ; int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK; int i; @@ -398,7 +391,7 @@ PP(pp_padrange) PP(pp_padsv) { - dVAR; dSP; + dSP; EXTEND(SP, 1); { OP * const op = PL_op; @@ -428,7 +421,6 @@ PP(pp_padsv) PP(pp_readline) { - dVAR; dSP; if (TOPs) { SvGETMAGIC(TOPs); @@ -452,7 +444,7 @@ PP(pp_readline) PP(pp_eq) { - dVAR; dSP; + dSP; SV *left, *right; tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric); @@ -468,7 +460,7 @@ PP(pp_eq) PP(pp_preinc) { - dVAR; dSP; + dSP; const bool inc = PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC; if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))) @@ -488,7 +480,7 @@ PP(pp_preinc) PP(pp_or) { - dVAR; dSP; + dSP; PERL_ASYNC_CHECK(); if (SvTRUE(TOPs)) RETURN; @@ -501,7 +493,7 @@ PP(pp_or) PP(pp_defined) { - dVAR; dSP; + dSP; SV* sv; bool defined; const int op_type = PL_op->op_type; @@ -559,7 +551,7 @@ PP(pp_defined) PP(pp_add) { - dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr; + dSP; dATARGET; bool useleft; SV *svl, *svr; tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric); svr = TOPs; svl = TOPm1s; @@ -724,7 +716,7 @@ PP(pp_add) PP(pp_aelemfast) { - dVAR; dSP; + dSP; AV * const av = PL_op->op_type == OP_AELEMFAST_LEX ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv); const U32 lval = PL_op->op_flags & OPf_MOD; @@ -743,7 +735,7 @@ PP(pp_aelemfast) PP(pp_join) { - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; MARK++; do_join(TARG, *MARK, MARK, SP); SP = MARK; @@ -753,7 +745,7 @@ PP(pp_join) PP(pp_pushre) { - dVAR; dSP; + dSP; #ifdef DEBUGGING /* * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs @@ -774,7 +766,7 @@ PP(pp_pushre) PP(pp_print) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; PerlIO *fp; MAGIC *mg; GV * const gv @@ -868,7 +860,7 @@ PP(pp_print) PP(pp_rv2av) { - dVAR; dSP; dTOPss; + dSP; dTOPss; const I32 gimme = GIMME_V; static const char an_array[] = "an ARRAY"; static const char a_hash[] = "a HASH"; @@ -962,8 +954,6 @@ PP(pp_rv2av) STATIC void S_do_oddball(pTHX_ SV **oddkey, SV **firstkey) { - dVAR; - PERL_ARGS_ASSERT_DO_ODDBALL; if (*oddkey) { @@ -1295,7 +1285,7 @@ PP(pp_aassign) PP(pp_qr) { - dVAR; dSP; + dSP; PMOP * const pm = cPMOP; REGEXP * rx = PM_GETRE(pm); SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL; @@ -1335,7 +1325,7 @@ PP(pp_qr) PP(pp_match) { - dVAR; dSP; dTARG; + dSP; dTARG; PMOP *pm = cPMOP; PMOP *dynpm = pm; const char *s; @@ -1531,7 +1521,7 @@ nope: OP * Perl_do_readline(pTHX) { - dVAR; dSP; dTARGETSTACKED; + dSP; dTARGETSTACKED; SV *sv; STRLEN tmplen = 0; STRLEN offset; @@ -1739,7 +1729,7 @@ Perl_do_readline(pTHX) PP(pp_helem) { - dVAR; dSP; + dSP; HE* he; SV **svp; SV * const keysv = POPs; @@ -1819,7 +1809,7 @@ PP(pp_helem) PP(pp_iter) { - dVAR; dSP; + dSP; PERL_CONTEXT *cx; SV *oldsv; SV **itersvp; @@ -2023,7 +2013,7 @@ pp_match is just a simpler version of the above. PP(pp_subst) { - dVAR; dSP; dTARG; + dSP; dTARG; PMOP *pm = cPMOP; PMOP *rpm = pm; char *s; @@ -2404,7 +2394,7 @@ PP(pp_subst) PP(pp_grepwhile) { - dVAR; dSP; + dSP; if (SvTRUEx(POPs)) PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; @@ -2461,7 +2451,7 @@ PP(pp_grepwhile) PP(pp_leavesub) { - dVAR; dSP; + dSP; SV **mark; SV **newsp; PMOP *newpm; @@ -2528,7 +2518,7 @@ PP(pp_leavesub) PP(pp_entersub) { - dVAR; dSP; dPOPss; + dSP; dPOPss; GV *gv; CV *cv; PERL_CONTEXT *cx; @@ -2830,7 +2820,7 @@ Perl_sub_crush_depth(pTHX_ CV *cv) PP(pp_aelem) { - dVAR; dSP; + dSP; SV** svp; SV* const elemsv = POPs; IV elem = SvIV(elemsv); @@ -2943,7 +2933,7 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) PP(pp_method) { - dVAR; dSP; + dSP; SV* const sv = TOPs; if (SvROK(sv)) { @@ -2960,7 +2950,7 @@ PP(pp_method) PP(pp_method_named) { - dVAR; dSP; + dSP; SV* const sv = cSVOP_sv; U32 hash = SvSHARED_HASH(sv); @@ -2971,7 +2961,6 @@ PP(pp_method_named) STATIC SV * S_method_common(pTHX_ SV* meth, U32* hashp) { - dVAR; SV* ob; GV* gv; HV* stash; diff --git a/pp_pack.c b/pp_pack.c index f877fe2..6b14751 100644 --- a/pp_pack.c +++ b/pp_pack.c @@ -337,7 +337,6 @@ uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len STATIC bool next_uni_uu(pTHX_ const char **s, const char *end, I32 *out) { - dVAR; STRLEN retlen; const UV val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, UTF8_CHECK_ONLY); if (val >= 0x100 || !ISUUCHAR(val) || @@ -862,7 +861,7 @@ Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, cons STATIC I32 S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const char *strend, const char **new_s ) { - dVAR; dSP; + dSP; SV *sv = NULL; const I32 start_sp_offset = SP - PL_stack_base; howlen_t howlen; @@ -1842,7 +1841,6 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c PP(pp_unpack) { - dVAR; dSP; dPOPPOPssrl; I32 gimme = GIMME_V; @@ -1975,7 +1973,6 @@ The engine implementing pack() Perl function. void Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist ) { - dVAR; tempsym_t sym; PERL_ARGS_ASSERT_PACKLIST; @@ -2077,7 +2074,6 @@ STATIC SV ** S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) { - dVAR; tempsym_t lookahead; I32 items = endlist - beglist; bool found = next_symbol(symptr); @@ -3092,7 +3088,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) PP(pp_pack) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; SV *cat = TARG; STRLEN fromlen; SV *pat_sv = *++MARK; diff --git a/pp_sort.c b/pp_sort.c index 0d9ef47..f75ecd9 100644 --- a/pp_sort.c +++ b/pp_sort.c @@ -347,14 +347,12 @@ typedef struct { static I32 cmp_desc(pTHX_ gptr const a, gptr const b) { - dVAR; return -PL_sort_RealCmp(aTHX_ a, b); } STATIC void S_mergesortsv(pTHX_ gptr *base, size_t nmemb, SVCOMPARE_t cmp, U32 flags) { - dVAR; IV i, run, offset; I32 sense, level; gptr *f1, *f2, *t, *b, *p; @@ -1322,7 +1320,6 @@ S_qsortsvu(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare) static I32 cmpindir(pTHX_ gptr const a, gptr const b) { - dVAR; gptr * const ap = (gptr *)a; gptr * const bp = (gptr *)b; const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp); @@ -1335,7 +1332,6 @@ cmpindir(pTHX_ gptr const a, gptr const b) static I32 cmpindir_desc(pTHX_ gptr const a, gptr const b) { - dVAR; gptr * const ap = (gptr *)a; gptr * const bp = (gptr *)b; const I32 sense = PL_sort_RealCmp(aTHX_ *ap, *bp); @@ -1351,7 +1347,6 @@ cmpindir_desc(pTHX_ gptr const a, gptr const b) STATIC void S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp, U32 flags) { - dVAR; if ((flags & SORTf_STABLE) != 0) { gptr **pp, *q; size_t n, j, i; @@ -1475,7 +1470,7 @@ Perl_sortsv_flags(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags) PP(pp_sort) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; SV **p1 = ORIGMARK+1, **p2; SSize_t max, i; AV* av = NULL; @@ -1512,7 +1507,7 @@ PP(pp_sort) SAVEVPTR(PL_sortcop); if (flags & OPf_STACKED) { if (flags & OPf_SPECIAL) { - OP *nullop = cLISTOP->op_first->op_sibling; /* pass pushmark */ + OP *nullop = OP_SIBLING(cLISTOP->op_first); /* pass pushmark */ assert(nullop->op_type == OP_NULL); PL_sortcop = nullop->op_next; } @@ -1774,7 +1769,6 @@ PP(pp_sort) static I32 S_sortcv(pTHX_ SV *const a, SV *const b) { - dVAR; const I32 oldsaveix = PL_savestack_ix; const I32 oldscopeix = PL_scopestack_ix; I32 result; @@ -1816,7 +1810,6 @@ S_sortcv(pTHX_ SV *const a, SV *const b) static I32 S_sortcv_stacked(pTHX_ SV *const a, SV *const b) { - dVAR; const I32 oldsaveix = PL_savestack_ix; const I32 oldscopeix = PL_scopestack_ix; I32 result; @@ -1873,7 +1866,7 @@ S_sortcv_stacked(pTHX_ SV *const a, SV *const b) static I32 S_sortcv_xsub(pTHX_ SV *const a, SV *const b) { - dVAR; dSP; + dSP; const I32 oldsaveix = PL_savestack_ix; const I32 oldscopeix = PL_scopestack_ix; CV * const cv=MUTABLE_CV(PL_sortcop); @@ -1941,7 +1934,6 @@ S_sv_i_ncmp(pTHX_ SV *const a, SV *const b) static I32 S_amagic_ncmp(pTHX_ SV *const a, SV *const b) { - dVAR; SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg); PERL_ARGS_ASSERT_AMAGIC_NCMP; @@ -1962,7 +1954,6 @@ S_amagic_ncmp(pTHX_ SV *const a, SV *const b) static I32 S_amagic_i_ncmp(pTHX_ SV *const a, SV *const b) { - dVAR; SV * const tmpsv = tryCALL_AMAGICbin(a,b,ncmp_amg); PERL_ARGS_ASSERT_AMAGIC_I_NCMP; @@ -1983,7 +1974,6 @@ S_amagic_i_ncmp(pTHX_ SV *const a, SV *const b) static I32 S_amagic_cmp(pTHX_ SV *const str1, SV *const str2) { - dVAR; SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg); PERL_ARGS_ASSERT_AMAGIC_CMP; @@ -2006,7 +1996,6 @@ S_amagic_cmp(pTHX_ SV *const str1, SV *const str2) static I32 S_amagic_cmp_locale(pTHX_ SV *const str1, SV *const str2) { - dVAR; SV * const tmpsv = tryCALL_AMAGICbin(str1,str2,scmp_amg); PERL_ARGS_ASSERT_AMAGIC_CMP_LOCALE; diff --git a/pp_sys.c b/pp_sys.c index a34df63..54c12b3 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -291,7 +291,7 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) PP(pp_backtick) { - dVAR; dSP; dTARGET; + dSP; dTARGET; PerlIO *fp; const char * const tmps = POPpconstx; const I32 gimme = GIMME_V; @@ -352,7 +352,6 @@ PP(pp_backtick) PP(pp_glob) { - dVAR; OP *result; dSP; GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs; @@ -412,14 +411,13 @@ PP(pp_glob) PP(pp_rcatline) { - dVAR; PL_last_in_gv = cGVOP_gv; return do_readline(); } PP(pp_warn) { - dVAR; dSP; dMARK; + dSP; dMARK; SV *exsv; STRLEN len; if (SP - MARK > 1) { @@ -468,7 +466,7 @@ PP(pp_warn) PP(pp_die) { - dVAR; dSP; dMARK; + dSP; dMARK; SV *exsv; STRLEN len; #ifdef VMS @@ -595,7 +593,7 @@ Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, PP(pp_open) { - dVAR; dSP; + dSP; dMARK; dORIGMARK; dTARGET; SV *sv; @@ -649,7 +647,7 @@ PP(pp_open) PP(pp_close) { - dVAR; dSP; + dSP; GV * const gv = MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs); @@ -672,7 +670,6 @@ PP(pp_close) PP(pp_pipe_op) { #ifdef HAS_PIPE - dVAR; dSP; IO *rstio; IO *wstio; @@ -729,7 +726,7 @@ badexit: PP(pp_fileno) { - dVAR; dSP; dTARGET; + dSP; dTARGET; GV *gv; IO *io; PerlIO *fp; @@ -761,7 +758,6 @@ PP(pp_fileno) PP(pp_umask) { - dVAR; dSP; #ifdef HAS_UMASK dTARGET; @@ -792,7 +788,7 @@ PP(pp_umask) PP(pp_binmode) { - dVAR; dSP; + dSP; GV *gv; IO *io; PerlIO *fp; @@ -853,7 +849,7 @@ PP(pp_binmode) PP(pp_tie) { - dVAR; dSP; dMARK; + dSP; dMARK; HV* stash; GV *gv = NULL; SV *sv; @@ -960,7 +956,7 @@ PP(pp_tie) PP(pp_untie) { - dVAR; dSP; + dSP; MAGIC *mg; SV *sv = POPs; const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) @@ -1000,7 +996,6 @@ PP(pp_untie) PP(pp_tied) { - dVAR; dSP; const MAGIC *mg; dTOPss; @@ -1024,7 +1019,7 @@ PP(pp_tied) PP(pp_dbmopen) { - dVAR; dSP; + dSP; dPOPPOPssrl; HV* stash; GV *gv = NULL; @@ -1081,7 +1076,7 @@ PP(pp_dbmopen) PP(pp_sselect) { #ifdef HAS_SELECT - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 i; I32 j; char *s; @@ -1261,7 +1256,6 @@ of the typeglob that PL_defoutgv points to is decreased by one. void Perl_setdefout(pTHX_ GV *gv) { - dVAR; PERL_ARGS_ASSERT_SETDEFOUT; SvREFCNT_inc_simple_void_NN(gv); SvREFCNT_dec(PL_defoutgv); @@ -1270,7 +1264,7 @@ Perl_setdefout(pTHX_ GV *gv) PP(pp_select) { - dVAR; dSP; dTARGET; + dSP; dTARGET; HV *hv; GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL; GV * egv = GvEGVx(PL_defoutgv); @@ -1301,7 +1295,7 @@ PP(pp_select) PP(pp_getc) { - dVAR; dSP; dTARGET; + dSP; dTARGET; GV * const gv = MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs); IO *const io = GvIO(gv); @@ -1348,7 +1342,6 @@ PP(pp_getc) STATIC OP * S_doform(pTHX_ CV *cv, GV *gv, OP *retop) { - dVAR; PERL_CONTEXT *cx; const I32 gimme = GIMME_V; @@ -1375,7 +1368,6 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PP(pp_enterwrite) { - dVAR; dSP; GV *gv; IO *io; @@ -1415,7 +1407,7 @@ PP(pp_enterwrite) PP(pp_leavewrite) { - dVAR; dSP; + dSP; GV * const gv = cxstack[cxstack_ix].blk_format.gv; IO * const io = GvIOp(gv); PerlIO *ofp; @@ -1532,7 +1524,7 @@ PP(pp_leavewrite) PP(pp_prtf) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; PerlIO *fp; GV * const gv @@ -1593,7 +1585,6 @@ PP(pp_prtf) PP(pp_sysopen) { - dVAR; dSP; const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666; const int mode = POPi; @@ -1615,7 +1606,7 @@ PP(pp_sysopen) PP(pp_sysread) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; SSize_t offset; IO *io; char *buffer; @@ -1871,7 +1862,7 @@ PP(pp_sysread) PP(pp_syswrite) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; SV *bufsv; const char *buffer; SSize_t retval; @@ -2072,7 +2063,7 @@ PP(pp_syswrite) PP(pp_eof) { - dVAR; dSP; + dSP; GV *gv; IO *io; const MAGIC *mg; @@ -2135,7 +2126,7 @@ PP(pp_eof) PP(pp_tell) { - dVAR; dSP; dTARGET; + dSP; dTARGET; GV *gv; IO *io; @@ -2169,7 +2160,7 @@ PP(pp_tell) PP(pp_sysseek) { - dVAR; dSP; + dSP; const int whence = POPi; #if LSEEKSIZE > IVSIZE const Off_t offset = (Off_t)SvNVx(POPs); @@ -2216,7 +2207,6 @@ PP(pp_sysseek) PP(pp_truncate) { - dVAR; dSP; /* There seems to be no consensus on the length type of truncate() * and ftruncate(), both off_t and size_t have supporters. In @@ -2306,7 +2296,7 @@ PP(pp_truncate) PP(pp_ioctl) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV * const argsv = POPs; const unsigned int func = POPu; int optype; @@ -2382,7 +2372,7 @@ PP(pp_ioctl) PP(pp_flock) { #ifdef FLOCK - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 value; const int argtype = POPi; GV * const gv = MUTABLE_GV(POPs); @@ -2402,7 +2392,7 @@ PP(pp_flock) PUSHi(value); RETURN; #else - DIE(aTHX_ PL_no_func, "flock()"); + DIE(aTHX_ PL_no_func, "flock"); #endif } @@ -2412,7 +2402,7 @@ PP(pp_flock) PP(pp_socket) { - dVAR; dSP; + dSP; const int protocol = POPi; const int type = POPi; const int domain = POPi; @@ -2450,7 +2440,7 @@ PP(pp_socket) PP(pp_sockpair) { #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET)) - dVAR; dSP; + dSP; int fd[2]; const int protocol = POPi; const int type = POPi; @@ -2501,7 +2491,7 @@ PP(pp_sockpair) PP(pp_bind) { - dVAR; dSP; + dSP; SV * const addrsv = POPs; /* OK, so on what platform does bind modify addr? */ const char *addr; @@ -2536,7 +2526,7 @@ nuts: PP(pp_listen) { - dVAR; dSP; + dSP; const int backlog = POPi; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); @@ -2557,7 +2547,7 @@ nuts: PP(pp_accept) { - dVAR; dSP; dTARGET; + dSP; dTARGET; IO *nstio; char namebuf[MAXPATHLEN]; #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) @@ -2622,7 +2612,7 @@ badexit: PP(pp_shutdown) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const int how = POPi; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); @@ -2641,7 +2631,7 @@ nuts: PP(pp_ssockopt) { - dVAR; dSP; + dSP; const int optype = PL_op->op_type; SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs; const unsigned int optname = (unsigned int) POPi; @@ -2715,7 +2705,7 @@ nuts2: PP(pp_getpeername) { - dVAR; dSP; + dSP; const int optype = PL_op->op_type; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); @@ -2779,7 +2769,6 @@ nuts2: PP(pp_stat) { - dVAR; dSP; GV *gv = NULL; IO *io = NULL; @@ -2979,7 +2968,6 @@ S_ft_return_true(pTHX_ SV *ret) { STATIC OP * S_try_amagic_ftest(pTHX_ char chr) { - dVAR; SV *const arg = *PL_stack_sp; assert(chr != '?'); @@ -3004,7 +2992,6 @@ S_try_amagic_ftest(pTHX_ char chr) { PP(pp_ftrread) { - dVAR; I32 result; /* Not const, because things tweak this below. Not bool, because there's no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */ @@ -3122,7 +3109,6 @@ PP(pp_ftrread) PP(pp_ftis) { - dVAR; I32 result; const int op_type = PL_op->op_type; char opchar = '?'; @@ -3174,7 +3160,6 @@ PP(pp_ftis) PP(pp_ftrowned) { - dVAR; I32 result; char opchar = '?'; @@ -3276,7 +3261,6 @@ PP(pp_ftrowned) PP(pp_ftlink) { - dVAR; I32 result; tryAMAGICftest_MG('l'); @@ -3291,7 +3275,6 @@ PP(pp_ftlink) PP(pp_fttty) { - dVAR; int fd; GV *gv; char *name = NULL; @@ -3326,7 +3309,6 @@ PP(pp_fttty) PP(pp_fttext) { - dVAR; I32 i; SSize_t len; I32 odd = 0; @@ -3509,7 +3491,7 @@ PP(pp_fttext) PP(pp_chdir) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const char *tmps = NULL; GV *gv = NULL; @@ -3587,7 +3569,7 @@ PP(pp_chdir) PP(pp_chown) { - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; const I32 value = (I32)apply(PL_op->op_type, MARK, SP); SP = MARK; @@ -3598,7 +3580,7 @@ PP(pp_chown) PP(pp_chroot) { #ifdef HAS_CHROOT - dVAR; dSP; dTARGET; + dSP; dTARGET; char * const tmps = POPpx; TAINT_PROPER("chroot"); PUSHi( chroot(tmps) >= 0 ); @@ -3610,7 +3592,7 @@ PP(pp_chroot) PP(pp_rename) { - dVAR; dSP; dTARGET; + dSP; dTARGET; int anum; const char * const tmps2 = POPpconstx; const char * const tmps = SvPV_nolen_const(TOPs); @@ -3636,7 +3618,7 @@ PP(pp_rename) #if defined(HAS_LINK) || defined(HAS_SYMLINK) PP(pp_link) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const int op_type = PL_op->op_type; int result; @@ -3684,7 +3666,6 @@ PP(pp_link) PP(pp_readlink) { - dVAR; dSP; #ifdef HAS_SYMLINK dTARGET; @@ -3812,7 +3793,7 @@ S_dooneliner(pTHX_ const char *cmd, const char *filename) PP(pp_mkdir) { - dVAR; dSP; dTARGET; + dSP; dTARGET; STRLEN len; const char *tmps; bool copy = FALSE; @@ -3839,7 +3820,7 @@ PP(pp_mkdir) PP(pp_rmdir) { - dVAR; dSP; dTARGET; + dSP; dTARGET; STRLEN len; const char *tmps; bool copy = FALSE; @@ -3861,7 +3842,7 @@ PP(pp_rmdir) PP(pp_open_dir) { #if defined(Direntry_t) && defined(HAS_READDIR) - dVAR; dSP; + dSP; const char * const dirname = POPpconstx; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); @@ -3893,7 +3874,6 @@ PP(pp_readdir) #if !defined(I_DIRENT) && !defined(VMS) Direntry_t *readdir (DIR *); #endif - dVAR; dSP; SV *sv; @@ -3941,7 +3921,7 @@ nope: PP(pp_telldir) { #if defined(HAS_TELLDIR) || defined(telldir) - dVAR; dSP; dTARGET; + dSP; dTARGET; /* XXX does _anyone_ need this? --AD 2/20/1998 */ /* XXX netbsd still seemed to. XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style. @@ -3973,7 +3953,7 @@ nope: PP(pp_seekdir) { #if defined(HAS_SEEKDIR) || defined(seekdir) - dVAR; dSP; + dSP; const long along = POPl; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); @@ -3999,7 +3979,7 @@ nope: PP(pp_rewinddir) { #if defined(HAS_REWINDDIR) || defined(rewinddir) - dVAR; dSP; + dSP; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); @@ -4023,7 +4003,7 @@ nope: PP(pp_closedir) { #if defined(Direntry_t) && defined(HAS_READDIR) - dVAR; dSP; + dSP; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); @@ -4058,7 +4038,7 @@ nope: PP(pp_fork) { #ifdef HAS_FORK - dVAR; dSP; dTARGET; + dSP; dTARGET; Pid_t childpid; #ifdef HAS_SIGPROCMASK sigset_t oldmask, newmask; @@ -4115,7 +4095,7 @@ PP(pp_fork) PP(pp_wait) { #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) - dVAR; dSP; dTARGET; + dSP; dTARGET; Pid_t childpid; int argflags; @@ -4143,7 +4123,7 @@ PP(pp_wait) PP(pp_waitpid) { #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) - dVAR; dSP; dTARGET; + dSP; dTARGET; const int optype = POPi; const Pid_t pid = TOPi; Pid_t result; @@ -4172,7 +4152,7 @@ PP(pp_waitpid) PP(pp_system) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; #if defined(__LIBCATAMOUNT__) PL_statusvalue = -1; SP = ORIGMARK; @@ -4326,7 +4306,7 @@ PP(pp_system) PP(pp_exec) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; I32 value; if (TAINTING_get) { @@ -4366,7 +4346,7 @@ PP(pp_exec) PP(pp_getppid) { #ifdef HAS_GETPPID - dVAR; dSP; dTARGET; + dSP; dTARGET; XPUSHi( getppid() ); RETURN; #else @@ -4377,7 +4357,7 @@ PP(pp_getppid) PP(pp_getpgrp) { #ifdef HAS_GETPGRP - dVAR; dSP; dTARGET; + dSP; dTARGET; Pid_t pgrp; const Pid_t pid = (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0); @@ -4392,14 +4372,14 @@ PP(pp_getpgrp) XPUSHi(pgrp); RETURN; #else - DIE(aTHX_ PL_no_func, "getpgrp()"); + DIE(aTHX_ PL_no_func, "getpgrp"); #endif } PP(pp_setpgrp) { #ifdef HAS_SETPGRP - dVAR; dSP; dTARGET; + dSP; dTARGET; Pid_t pgrp; Pid_t pid; pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0; @@ -4422,7 +4402,7 @@ PP(pp_setpgrp) #endif /* USE_BSDPGRP */ RETURN; #else - DIE(aTHX_ PL_no_func, "setpgrp()"); + DIE(aTHX_ PL_no_func, "setpgrp"); #endif } @@ -4435,20 +4415,20 @@ PP(pp_setpgrp) PP(pp_getpriority) { #ifdef HAS_GETPRIORITY - dVAR; dSP; dTARGET; + dSP; dTARGET; const int who = POPi; const int which = TOPi; SETi( getpriority(PRIORITY_WHICH_T(which), who) ); RETURN; #else - DIE(aTHX_ PL_no_func, "getpriority()"); + DIE(aTHX_ PL_no_func, "getpriority"); #endif } PP(pp_setpriority) { #ifdef HAS_SETPRIORITY - dVAR; dSP; dTARGET; + dSP; dTARGET; const int niceval = POPi; const int who = POPi; const int which = TOPi; @@ -4456,7 +4436,7 @@ PP(pp_setpriority) SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 ); RETURN; #else - DIE(aTHX_ PL_no_func, "setpriority()"); + DIE(aTHX_ PL_no_func, "setpriority"); #endif } @@ -4466,7 +4446,7 @@ PP(pp_setpriority) PP(pp_time) { - dVAR; dSP; dTARGET; + dSP; dTARGET; #ifdef BIG_TIME XPUSHn( time(NULL) ); #else @@ -4478,7 +4458,6 @@ PP(pp_time) PP(pp_tms) { #ifdef HAS_TIMES - dVAR; dSP; struct tms timesbuf; @@ -4520,7 +4499,6 @@ PP(pp_tms) PP(pp_gmtime) { - dVAR; dSP; Time64_T when; struct TM tmbuf; @@ -4613,7 +4591,7 @@ PP(pp_gmtime) PP(pp_alarm) { #ifdef HAS_ALARM - dVAR; dSP; dTARGET; + dSP; dTARGET; int anum; anum = POPi; anum = alarm((unsigned int)anum); @@ -4628,7 +4606,7 @@ PP(pp_alarm) PP(pp_sleep) { - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 duration; Time_t lasttime; Time_t when; @@ -4651,7 +4629,7 @@ PP(pp_sleep) PP(pp_shmwrite) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; const int op_type = PL_op->op_type; I32 value; @@ -4683,7 +4661,7 @@ PP(pp_shmwrite) PP(pp_semget) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; const int anum = do_ipcget(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) @@ -4698,7 +4676,7 @@ PP(pp_semget) PP(pp_semctl) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; const int anum = do_ipcctl(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) @@ -4743,7 +4721,7 @@ S_space_join_names_mortal(pTHX_ char *const *array) PP(pp_ghostent) { #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; char **elem; SV *sv; @@ -4833,7 +4811,7 @@ PP(pp_ghostent) PP(pp_gnetent) { #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; SV *sv; #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */ @@ -4906,7 +4884,7 @@ PP(pp_gnetent) PP(pp_gprotoent) { #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; SV *sv; #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */ @@ -4966,7 +4944,7 @@ PP(pp_gprotoent) PP(pp_gservent) { #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; SV *sv; #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */ @@ -5030,7 +5008,7 @@ PP(pp_gservent) PP(pp_shostent) { - dVAR; dSP; + dSP; const int stayopen = TOPi; switch(PL_op->op_type) { case OP_SHOSTENT: @@ -5067,7 +5045,7 @@ PP(pp_shostent) PP(pp_ehostent) { - dVAR; dSP; + dSP; switch(PL_op->op_type) { case OP_EHOSTENT: #ifdef HAS_ENDHOSTENT @@ -5133,7 +5111,7 @@ PP(pp_ehostent) PP(pp_gpwent) { #ifdef HAS_PASSWD - dVAR; dSP; + dSP; I32 which = PL_op->op_type; SV *sv; struct passwd *pwent = NULL; @@ -5348,7 +5326,7 @@ PP(pp_gpwent) PP(pp_ggrent) { #ifdef HAS_GROUP - dVAR; dSP; + dSP; const I32 which = PL_op->op_type; const struct group *grent; @@ -5414,7 +5392,7 @@ PP(pp_ggrent) PP(pp_getlogin) { #ifdef HAS_GETLOGIN - dVAR; dSP; dTARGET; + dSP; dTARGET; char *tmps; EXTEND(SP, 1); if (!(tmps = PerlProc_getlogin())) @@ -5432,7 +5410,7 @@ PP(pp_getlogin) PP(pp_syscall) { #ifdef HAS_SYSCALL - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; I32 items = SP - MARK; unsigned long a[20]; I32 i = 0; diff --git a/proto.h b/proto.h index 3c8888e..49a44d2 100644 --- a/proto.h +++ b/proto.h @@ -374,16 +374,16 @@ PERL_CALLCONV bool Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t* s #define PERL_ARGS_ASSERT_CANDO \ assert(statbufp) -PERL_CALLCONV I32 Perl_cast_i32(pTHX_ NV f) +PERL_CALLCONV I32 Perl_cast_i32(NV f) __attribute__warn_unused_result__; -PERL_CALLCONV IV Perl_cast_iv(pTHX_ NV f) +PERL_CALLCONV IV Perl_cast_iv(NV f) __attribute__warn_unused_result__; -PERL_CALLCONV U32 Perl_cast_ulong(pTHX_ NV f) +PERL_CALLCONV U32 Perl_cast_ulong(NV f) __attribute__warn_unused_result__; -PERL_CALLCONV UV Perl_cast_uv(pTHX_ NV f) +PERL_CALLCONV UV Perl_cast_uv(NV f) __attribute__warn_unused_result__; PERL_CALLCONV bool Perl_check_utf8_print(pTHX_ const U8 *s, const STRLEN len) @@ -793,10 +793,10 @@ PERL_CALLCONV CV* Perl_cv_clone_into(pTHX_ CV* proto, CV *target) #define PERL_ARGS_ASSERT_CV_CLONE_INTO \ assert(proto); assert(target) -PERL_CALLCONV SV* Perl_cv_const_sv(pTHX_ const CV *const cv) +PERL_CALLCONV SV* Perl_cv_const_sv(const CV *const cv) __attribute__warn_unused_result__; -PERL_CALLCONV SV* Perl_cv_const_sv_or_av(pTHX_ const CV *const cv) +PERL_CALLCONV SV* Perl_cv_const_sv_or_av(const CV *const cv) __attribute__warn_unused_result__; PERL_CALLCONV void Perl_cv_forget_slab(pTHX_ CV *cv) @@ -1308,6 +1308,11 @@ PERL_CALLCONV int Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) #define PERL_ARGS_ASSERT_GROK_NUMBER \ assert(pv) +PERL_CALLCONV int Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS \ + assert(pv) + PERL_CALLCONV bool Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) @@ -2551,7 +2556,7 @@ PERL_CALLCONV int Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) #define PERL_ARGS_ASSERT_MG_COPY \ assert(sv); assert(nsv) -PERL_CALLCONV MAGIC* Perl_mg_find(pTHX_ const SV* sv, int type) +PERL_CALLCONV MAGIC* Perl_mg_find(const SV* sv, int type) __attribute__warn_unused_result__; PERL_CALLCONV MAGIC* Perl_mg_find_mglob(pTHX_ SV* sv) @@ -2560,7 +2565,7 @@ PERL_CALLCONV MAGIC* Perl_mg_find_mglob(pTHX_ SV* sv) #define PERL_ARGS_ASSERT_MG_FIND_MGLOB \ assert(sv) -PERL_CALLCONV MAGIC* Perl_mg_findext(pTHX_ const SV* sv, int type, const MGVTBL *vtbl) +PERL_CALLCONV MAGIC* Perl_mg_findext(const SV* sv, int type, const MGVTBL *vtbl) __attribute__warn_unused_result__; PERL_CALLCONV int Perl_mg_free(pTHX_ SV* sv) @@ -2590,8 +2595,8 @@ PERL_CALLCONV void Perl_mg_localize(pTHX_ SV* sv, SV* nsv, bool setmagic) #define PERL_ARGS_ASSERT_MG_LOCALIZE \ assert(sv); assert(nsv) -PERL_CALLCONV void Perl_mg_magical(pTHX_ SV* sv) - __attribute__nonnull__(pTHX_1); +PERL_CALLCONV void Perl_mg_magical(SV* sv) + __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_MG_MAGICAL \ assert(sv) @@ -2605,8 +2610,8 @@ PERL_CALLCONV I32 Perl_mg_size(pTHX_ SV* sv) #define PERL_ARGS_ASSERT_MG_SIZE \ assert(sv) -PERL_CALLCONV void Perl_mini_mktime(pTHX_ struct tm *ptm) - __attribute__nonnull__(pTHX_1); +PERL_CALLCONV void Perl_mini_mktime(struct tm *ptm) + __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_MINI_MKTIME \ assert(ptm) @@ -2688,7 +2693,7 @@ PERL_CALLCONV OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs) assert(o) PERL_CALLCONV void Perl_my_clearenv(pTHX); -PERL_CALLCONV int Perl_my_dirfd(pTHX_ DIR* dir); +PERL_CALLCONV int Perl_my_dirfd(DIR* dir); PERL_CALLCONV_NO_RET void Perl_my_exit(pTHX_ U32 status) __attribute__noreturn__; @@ -3116,10 +3121,20 @@ PERL_CALLCONV void Perl_op_null(pTHX_ OP* o) #define PERL_ARGS_ASSERT_OP_NULL \ assert(o) +PERL_CALLCONV OP* Perl_op_parent(OP *o) + __attribute__nonnull__(1); +#define PERL_ARGS_ASSERT_OP_PARENT \ + assert(o) + PERL_CALLCONV OP* Perl_op_prepend_elem(pTHX_ I32 optype, OP* first, OP* last); PERL_CALLCONV void Perl_op_refcnt_lock(pTHX); PERL_CALLCONV void Perl_op_refcnt_unlock(pTHX); PERL_CALLCONV OP* Perl_op_scope(pTHX_ OP* o); +PERL_CALLCONV OP* Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) + __attribute__nonnull__(1); +#define PERL_ARGS_ASSERT_OP_SIBLING_SPLICE \ + assert(parent) + PERL_CALLCONV OP* Perl_op_unscope(pTHX_ OP* o); PERL_CALLCONV void Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist, SV ***next_in_list, U32 flags) __attribute__nonnull__(pTHX_1) @@ -3995,8 +4010,8 @@ 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(pTHX_ SV *const sv) - __attribute__nonnull__(pTHX_1); +PERL_CALLCONV int Perl_sv_backoff(SV *const sv) + __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_SV_BACKOFF \ assert(sv) @@ -4815,10 +4830,10 @@ PERL_CALLCONV IV Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b) #define PERL_ARGS_ASSERT_UTF8_DISTANCE \ assert(a); assert(b) -PERL_CALLCONV U8* Perl_utf8_hop(pTHX_ const U8 *s, I32 off) +PERL_CALLCONV U8* Perl_utf8_hop(const U8 *s, I32 off) __attribute__warn_unused_result__ __attribute__pure__ - __attribute__nonnull__(pTHX_1); + __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_UTF8_HOP \ assert(s) @@ -6034,9 +6049,9 @@ STATIC void S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags) STATIC void S_unwind_handler_stack(pTHX_ const void *p); #endif #if defined(PERL_IN_MG_C) || defined(PERL_IN_PP_C) -PERL_CALLCONV bool Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv, bool pos1_is_uv, IV len_iv, bool len_is_uv, STRLEN *posp, STRLEN *lenp) - __attribute__nonnull__(pTHX_6) - __attribute__nonnull__(pTHX_7); +PERL_CALLCONV bool Perl_translate_substr_offsets(STRLEN curlen, IV pos1_iv, bool pos1_is_uv, IV len_iv, bool len_is_uv, STRLEN *posp, STRLEN *lenp) + __attribute__nonnull__(6) + __attribute__nonnull__(7); #define PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS \ assert(posp); assert(lenp) @@ -6118,7 +6133,7 @@ STATIC OP* S_fold_constants(pTHX_ OP *o) #define PERL_ARGS_ASSERT_FOLD_CONSTANTS \ assert(o) -STATIC OP* S_force_list(pTHX_ OP* arg); +STATIC OP* S_force_list(pTHX_ OP* arg, bool nullit); STATIC void S_forget_pmop(pTHX_ PMOP *const o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_FORGET_PMOP \ @@ -7139,10 +7154,10 @@ PERL_STATIC_INLINE bool S_grok_bslash_x(pTHX_ char** s, UV* uv, const char** err #define PERL_ARGS_ASSERT_GROK_BSLASH_X \ assert(s); assert(uv); assert(error_msg) -PERL_STATIC_INLINE I32 S_regcurly(pTHX_ const char *s) +PERL_STATIC_INLINE I32 S_regcurly(const char *s) __attribute__warn_unused_result__ __attribute__pure__ - __attribute__nonnull__(pTHX_1); + __attribute__nonnull__(1); #define PERL_ARGS_ASSERT_REGCURLY \ assert(s) @@ -7378,6 +7393,11 @@ STATIC void S_not_a_number(pTHX_ SV *const sv) #define PERL_ARGS_ASSERT_NOT_A_NUMBER \ assert(sv) +STATIC void S_not_incrementable(pTHX_ SV *const sv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_NOT_INCREMENTABLE \ + assert(sv) + STATIC PTR_TBL_ENT_t * S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv) __attribute__warn_unused_result__ __attribute__nonnull__(1); @@ -7394,6 +7414,12 @@ STATIC void S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flag #define PERL_ARGS_ASSERT_SV_ADD_ARENA \ assert(ptr) +STATIC const char * S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_SV_DISPLAY \ + assert(sv); assert(tmpbuf) + STATIC STRLEN S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target, const U8 *end, STRLEN endu) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) diff --git a/reentr.c b/reentr.c index 917807c..9a10dca 100644 --- a/reentr.c +++ b/reentr.c @@ -29,6 +29,7 @@ void Perl_reentrant_size(pTHX) { + PERL_UNUSED_CONTEXT; #ifdef USE_REENTRANT_API #define REENTRANTSMALLSIZE 256 /* Make something up. */ #define REENTRANTUSUALSIZE 4096 /* Make something up. */ @@ -139,6 +140,7 @@ Perl_reentrant_size(pTHX) { void Perl_reentrant_init(pTHX) { + PERL_UNUSED_CONTEXT; #ifdef USE_REENTRANT_API Newx(PL_reentrant_buffer, 1, REENTR); Perl_reentrant_size(aTHX); @@ -215,6 +217,7 @@ Perl_reentrant_init(pTHX) { void Perl_reentrant_free(pTHX) { + PERL_UNUSED_CONTEXT; #ifdef USE_REENTRANT_API #ifdef HAS_ASCTIME_R Safefree(PL_reentrant_buffer->_asctime_buffer); diff --git a/regcomp.c b/regcomp.c index b7a7b35..3d4d348 100644 --- a/regcomp.c +++ b/regcomp.c @@ -1948,7 +1948,6 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth) { - dVAR; /* first pass, loop through and scan words */ reg_trie_data *trie; HV *widecharmap = NULL; @@ -3594,7 +3593,6 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, /* recursed: which subroutines have we recursed into */ /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */ { - dVAR; /* There must be at least this number of characters to match */ SSize_t min = 0; I32 pars = 0, code; @@ -5522,7 +5520,6 @@ S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n) void Perl_reginitcolors(pTHX) { - dVAR; const char * const s = PerlEnv_getenv("PERL_RE_COLORS"); if (s) { char *t = savepv(s); @@ -5576,8 +5573,6 @@ Perl_reginitcolors(pTHX) regexp_engine const * Perl_current_re_engine(pTHX) { - dVAR; - if (IN_PERL_COMPILETIME) { HV * const table = GvHV(PL_hintgv); SV **ptr; @@ -5604,7 +5599,6 @@ Perl_current_re_engine(pTHX) REGEXP * Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags) { - dVAR; regexp_engine const *eng = current_re_engine(); GET_RE_DEBUG_FLAGS_DECL; @@ -5756,7 +5750,7 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state, if (oplist) { assert(oplist->op_type == OP_PADAV || oplist->op_type == OP_RV2AV); - oplist = oplist->op_sibling;; + oplist = OP_SIBLING(oplist); } if (SvRMAGICAL(av)) { @@ -5803,10 +5797,10 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state, pRExC_state->code_blocks[n].src_regex = NULL; n++; code = 1; - oplist = oplist->op_sibling; /* skip CONST */ + oplist = OP_SIBLING(oplist); /* skip CONST */ assert(oplist); } - oplist = oplist->op_sibling;; + oplist = OP_SIBLING(oplist);; } /* apply magic and QR overloading to arg */ @@ -6243,7 +6237,6 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, OP *expr, const regexp_engine* eng, REGEXP *old_re, bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags) { - dVAR; REGEXP *rx; struct regexp *r; regexp_internal *ri; @@ -6305,7 +6298,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, OP *o; int ncode = 0; - for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) + for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) ncode++; /* count of DO blocks */ if (ncode) { @@ -6326,7 +6319,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, if (expr->op_type == OP_CONST) n = 1; else - for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { + for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) { if (o->op_type == OP_CONST) n++; } @@ -6342,7 +6335,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, if (expr->op_type == OP_CONST) new_patternp[n] = cSVOPx_sv(expr); else - for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { + for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) { if (o->op_type == OP_CONST) new_patternp[n++] = cSVOPo_sv; } @@ -6362,7 +6355,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, assert( expr->op_type == OP_PUSHMARK || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK) || expr->op_type == OP_PADRANGE); - expr = expr->op_sibling; + expr = OP_SIBLING(expr); } pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count, @@ -6864,6 +6857,7 @@ reStudy: goto again; } else if ((!sawopen || !RExC_sawback) && + !sawlookahead && (OP(first) == STAR && PL_regkind[OP(NEXTOPER(first))] == REG_ANY) && !(r->intflags & PREGf_ANCH) && !pRExC_state->num_code_blocks) @@ -9461,7 +9455,6 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) * RExC_parse beyond the '('. Things like '(?' are indivisible tokens, and * this flag alerts us to the need to check for that */ { - dVAR; regnode *ret; /* Will be the head of the group. */ regnode *br; regnode *lastbr; @@ -10370,7 +10363,6 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) STATIC regnode * S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) { - dVAR; regnode *ret; regnode *chain = NULL; regnode *latest; @@ -10452,7 +10444,6 @@ S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) STATIC regnode * S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) { - dVAR; regnode *ret; char op; char *next; @@ -11240,7 +11231,6 @@ S_backref_value(char *p) STATIC regnode * S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) { - dVAR; regnode *ret = NULL; I32 flags = 0; char *parse_start = RExC_parse; @@ -11398,6 +11388,9 @@ tryagain: ret = reg_node(pRExC_state, CANY); RExC_seen |= REG_CANY_SEEN; *flagp |= HASWIDTH|SIMPLE; + if (SIZE_ONLY) { + ckWARNdep(RExC_parse+1, "\\C is deprecated"); + } goto finish_meta_pat; case 'X': ret = reg_node(pRExC_state, CLUMP); @@ -12510,7 +12503,6 @@ S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr) PERL_STATIC_INLINE I32 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, const bool strict) { - dVAR; I32 namedclass = OOB_NAMEDCLASS; PERL_ARGS_ASSERT_REGPPOSIXCC; @@ -13205,9 +13197,10 @@ S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invl * disk to find the possible matches. * * This should be called only for a Latin1-range code points, cp, which is - * known to be involved in a fold with other code points above Latin1. It - * would give false results if /aa has been specified. Multi-char folds - * are outside the scope of this, and must be handled specially. + * known to be involved in a simple fold with other code points above + * Latin1. It would give false results if /aa has been specified. + * Multi-char folds are outside the scope of this, and must be handled + * specially. * * XXX It would be better to generate these via regen, in case a new * version of the Unicode standard adds new mappings, though that is not @@ -13216,6 +13209,8 @@ S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invl PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS; + assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp)); + switch (cp) { case 'k': case 'K': @@ -13241,22 +13236,6 @@ S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invl case LATIN_SMALL_LETTER_SHARP_S: *invlist = add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_SHARP_S); break; - case 'F': case 'f': - case 'I': case 'i': - case 'L': case 'l': - case 'T': case 't': - case 'A': case 'a': - case 'H': case 'h': - case 'J': case 'j': - case 'N': case 'n': - case 'W': case 'w': - case 'Y': case 'y': - /* These all are targets of multi-character folds from code points - * that require UTF8 to express, so they can't match unless the - * target string is in UTF-8, so no action here is necessary, as - * regexec.c properly handles the general case for UTF-8 matching - * and multi-char folds */ - break; default: /* Use deprecated warning to increase the chances of this being * output */ @@ -13306,7 +13285,6 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * to be restarted. This can only happen if ret_invlist is non-NULL. */ - dVAR; UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE; IV range = 0; UV value = OOB_UNICODE, save_value = OOB_UNICODE; @@ -15041,7 +15019,7 @@ S_reg_skipcomment(RExC_state_t *pRExC_state, char* p) { PERL_ARGS_ASSERT_REG_SKIPCOMMENT; - assert(*p = '#'); + assert(*p == '#'); while (p < RExC_end) { if (*(++p) == '\n') { @@ -15107,7 +15085,6 @@ S_nextchar(pTHX_ RExC_state_t *pRExC_state) STATIC regnode * /* Location. */ S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) { - dVAR; regnode *ptr; regnode * const ret = RExC_emit; GET_RE_DEBUG_FLAGS_DECL; @@ -15150,7 +15127,6 @@ S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) STATIC regnode * /* Location. */ S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg) { - dVAR; regnode *ptr; regnode * const ret = RExC_emit; GET_RE_DEBUG_FLAGS_DECL; @@ -15208,8 +15184,6 @@ S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg) PERL_STATIC_INLINE STRLEN S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s) { - dVAR; - PERL_ARGS_ASSERT_REGUNI; return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s); @@ -15223,7 +15197,6 @@ S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s) STATIC void S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) { - dVAR; regnode *src; regnode *dst; regnode *place; @@ -15315,7 +15288,6 @@ STATIC void S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth) { - dVAR; regnode *scan; GET_RE_DEBUG_FLAGS_DECL; @@ -15966,7 +15938,6 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ SV * Perl_re_intuit_string(pTHX_ REGEXP * const r) { /* Assume that RE_INTUIT is set */ - dVAR; struct regexp *const prog = ReANY(r); GET_RE_DEBUG_FLAGS_DECL; @@ -16014,7 +15985,6 @@ Perl_pregfree(pTHX_ REGEXP *r) void Perl_pregfree2(pTHX_ REGEXP *rx) { - dVAR; struct regexp *const r = ReANY(rx); GET_RE_DEBUG_FLAGS_DECL; @@ -16143,7 +16113,6 @@ Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx) void Perl_regfree_internal(pTHX_ REGEXP * const rx) { - dVAR; struct regexp *const r = ReANY(rx); RXi_GET_DECL(r,ri); GET_RE_DEBUG_FLAGS_DECL; @@ -16196,6 +16165,9 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) Used in stclass optimization only */ U32 refcount; reg_ac_data *aho=(reg_ac_data*)ri->data->data[n]; +#ifdef USE_ITHREADS + dVAR; +#endif OP_REFCNT_LOCK; refcount = --aho->refcount; OP_REFCNT_UNLOCK; @@ -16222,6 +16194,9 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) /* trie structure. */ U32 refcount; reg_trie_data *trie=(reg_trie_data*)ri->data->data[n]; +#ifdef USE_ITHREADS + dVAR; +#endif OP_REFCNT_LOCK; refcount = --trie->refcount; OP_REFCNT_UNLOCK; @@ -16472,7 +16447,6 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) regnode * Perl_regnext(pTHX_ regnode *p) { - dVAR; I32 offset; if (!p) @@ -16528,8 +16502,6 @@ S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...) void Perl_save_re_context(pTHX) { - dVAR; - /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */ if (PL_curpm) { const REGEXP * const rx = PM_GETRE(PL_curpm); @@ -16586,40 +16558,104 @@ S_put_range(pTHX_ SV *sv, UV start, UV end) { /* Appends to 'sv' a displayable version of the range of code points from - * 'start' to 'end' */ + * 'start' to 'end'. It assumes that only ASCII printables are displayable + * as-is (though some of these will be escaped by put_byte()). For the + * time being, this subroutine only works for latin1 (< 256) code points */ assert(start <= end); PERL_ARGS_ASSERT_PUT_RANGE; - if (end - start < 3) { /* Individual chars in short ranges */ - for (; start <= end; start++) - put_byte(sv, start); - } - else if ( end > 255 - || ! isALPHANUMERIC(start) - || ! isALPHANUMERIC(end) - || isDIGIT(start) != isDIGIT(end) - || isUPPER(start) != isUPPER(end) - || isLOWER(start) != isLOWER(end) - - /* This final test should get optimized out except on EBCDIC - * platforms, where it causes ranges that cross discontinuities - * like i/j to be shown as hex instead of the misleading, - * e.g. H-K (since that range includes more than H, I, J, K). - * */ - || (end - start) != NATIVE_TO_ASCII(end) - NATIVE_TO_ASCII(start)) - { + while (start <= end) { + if (end - start < 3) { /* Individual chars in short ranges */ + for (; start <= end; start++) { + put_byte(sv, start); + } + break; + } + + /* For small ranges that include printable ASCII characters, it's more + * legible to print those characters rather than hex values. For + * larger ranges that include more than printables, it's probably + * clearer to just give the start and end points of the range in hex, + * and that's all we can do if there aren't any printables within the + * range + * + * On ASCII platforms the range of printables is contiguous. If the + * entire range is printable, we print each character as such. If the + * range is partially printable and partially not, it's less likely + * that the individual printables are meaningful, especially if all or + * almost all of them are in the range. But we err on the side of the + * individual printables being meaningful by using the hex only if the + * range contains all but 2 of the printables. + * + * On EBCDIC platforms, the printables are scattered around so that the + * maximum range length containing only them is about 10. Anything + * longer we treat as hex; otherwise we examine the range character by + * character to see */ +#ifdef EBCDIC + if (start < 256 && (((end < 255) ? end : 255) - start <= 10)) +#else + if ((isPRINT_A(start) && isPRINT_A(end)) + || (end >= 0x7F && (isPRINT_A(start) && start > 0x21)) + || ((end < 0x7D && isPRINT_A(end)) && start < 0x20)) +#endif + { + /* If the range beginning isn't an ASCII printable, we find the + * last such in the range, then split the output, so all the + * non-printables are in one subrange; then process the remaining + * portion as usual. If the entire range isn't printables, we + * don't split, but drop down to print as hex */ + if (! isPRINT_A(start)) { + UV temp_end = start + 1; + while (temp_end <= end && ! isPRINT_A(temp_end)) { + temp_end++; + } + if (temp_end <= end) { + put_range(sv, start, temp_end - 1); + start = temp_end; + continue; + } + } + + /* If the range beginning is a digit, output a subrange of just the + * digits, then process the remaining portion as usual */ + if (isDIGIT_A(start)) { + put_byte(sv, start); + sv_catpvs(sv, "-"); + while (start <= end && isDIGIT_A(start)) start++; + put_byte(sv, start - 1); + continue; + } + + /* Similarly for alphabetics. Because in both ASCII and EBCDIC, + * the code points for upper and lower A-Z and a-z aren't + * intermixed, the resulting subrange will consist solely of either + * upper- or lower- alphabetics */ + if (isALPHA_A(start)) { + put_byte(sv, start); + sv_catpvs(sv, "-"); + while (start <= end && isALPHA_A(start)) start++; + put_byte(sv, start - 1); + continue; + } + + /* We output any remaining printables as individual characters */ + if (isPUNCT_A(start) || isSPACE_A(start)) { + while (start <= end && (isPUNCT_A(start) || isSPACE_A(start))) { + put_byte(sv, start); + start++; + } + continue; + } + } + + /* Here is a control or non-ascii. Output the range or subrange as + * hex. */ Perl_sv_catpvf(aTHX_ sv, "\\x{%02" UVXf "}-\\x{%02" UVXf "}", start, (end < 256) ? end : 255); - } - else { /* Here, the ends of the range are both digits, or both uppercase, - or both lowercase; and there's no discontinuity in the range - (which could happen on EBCDIC platforms) */ - put_byte(sv, start); - sv_catpvs(sv, "-"); - put_byte(sv, end); + break; } } diff --git a/regen/keywords.pl b/regen/keywords.pl index bbc4188..b77fd67 100755 --- a/regen/keywords.pl +++ b/regen/keywords.pl @@ -75,8 +75,6 @@ print $c <<"END"; I32 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) { - dVAR; - PERL_ARGS_ASSERT_KEYWORD; $switch diff --git a/regen/reentr.pl b/regen/reentr.pl index e4cbde3..f22f085 100644 --- a/regen/reentr.pl +++ b/regen/reentr.pl @@ -769,6 +769,7 @@ print $c <<"EOF"; void Perl_reentrant_size(pTHX) { + PERL_UNUSED_CONTEXT; #ifdef USE_REENTRANT_API #define REENTRANTSMALLSIZE 256 /* Make something up. */ #define REENTRANTUSUALSIZE 4096 /* Make something up. */ @@ -778,6 +779,7 @@ Perl_reentrant_size(pTHX) { void Perl_reentrant_init(pTHX) { + PERL_UNUSED_CONTEXT; #ifdef USE_REENTRANT_API Newx(PL_reentrant_buffer, 1, REENTR); Perl_reentrant_size(aTHX); @@ -787,6 +789,7 @@ Perl_reentrant_init(pTHX) { void Perl_reentrant_free(pTHX) { + PERL_UNUSED_CONTEXT; #ifdef USE_REENTRANT_API @free Safefree(PL_reentrant_buffer); diff --git a/regen/warnings.pl b/regen/warnings.pl index 49fc88a..a9b3649 100644 --- a/regen/warnings.pl +++ b/regen/warnings.pl @@ -104,6 +104,9 @@ my $tree = { [ 5.021, DEFAULT_ON ], }], + 'missing' => [ 5.021, DEFAULT_OFF], + 'redundant' => [ 5.021, DEFAULT_OFF], + #'default' => [ 5.008, DEFAULT_ON ], }], } ; @@ -472,7 +475,7 @@ read_only_bottom_close_and_rename($pm); __END__ package warnings; -our $VERSION = '1.24'; +our $VERSION = '1.26'; # Verify that we're called correctly so that warnings will work. # see also strict.pm. @@ -743,6 +746,10 @@ Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a sub-category of the "syntax" category. It is now a top-level category in its own right. +Note: Before 5.21.0, the "missing" lexical warnings category was +internally defined to be the same as the "uninitialized" category. It +is now a top-level category in its own right. + =head2 Fatal Warnings X diff --git a/regexec.c b/regexec.c index 1aafcc7..58b3f60 100644 --- a/regexec.c +++ b/regexec.c @@ -288,7 +288,6 @@ static regmatch_state * S_push_slab(pTHX); STATIC CHECKPOINT S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) { - dVAR; const int retval = PL_savestack_ix; const int paren_elems_to_push = (maxopenparen - parenfloor) * REGCP_PAREN_ELEMS; @@ -369,7 +368,6 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) STATIC void S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p) { - dVAR; UV i; U32 paren; GET_RE_DEBUG_FLAGS_DECL; @@ -649,7 +647,6 @@ Perl_re_intuit_start(pTHX_ const U32 flags, re_scream_pos_data *data) { - dVAR; struct regexp *const prog = ReANY(rx); SSize_t start_shift = prog->check_offset_min; /* Should be nonnegative! */ @@ -1505,10 +1502,14 @@ STMT_START { } \ } STMT_END -#define REXEC_FBC_EXACTISH_SCAN(CoNd) \ +#define DUMP_EXEC_POS(li,s,doutf8) \ + dump_exec_pos(li,s,(reginfo->strend),(reginfo->strbeg), \ + startpos, doutf8) + +#define REXEC_FBC_EXACTISH_SCAN(COND) \ STMT_START { \ while (s <= e) { \ - if ( (CoNd) \ + if ( (COND) \ && (ln == 1 || folder(s, pat_string, ln)) \ && (reginfo->intuit || regtry(reginfo, &s)) )\ goto got_it; \ @@ -1516,148 +1517,199 @@ STMT_START { \ } \ } STMT_END -#define REXEC_FBC_UTF8_SCAN(CoDe) \ +#define REXEC_FBC_UTF8_SCAN(CODE) \ STMT_START { \ while (s < strend) { \ - CoDe \ + CODE \ s += UTF8SKIP(s); \ } \ } STMT_END -#define REXEC_FBC_SCAN(CoDe) \ +#define REXEC_FBC_SCAN(CODE) \ STMT_START { \ while (s < strend) { \ - CoDe \ + CODE \ s++; \ } \ } STMT_END -#define REXEC_FBC_UTF8_CLASS_SCAN(CoNd) \ -REXEC_FBC_UTF8_SCAN( \ - if (CoNd) { \ - if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \ - goto got_it; \ - else \ - tmp = doevery; \ - } \ - else \ - tmp = 1; \ +#define REXEC_FBC_UTF8_CLASS_SCAN(COND) \ +REXEC_FBC_UTF8_SCAN( /* Loops while (s < strend) */ \ + if (COND) { \ + if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \ + goto got_it; \ + else \ + tmp = doevery; \ + } \ + else \ + tmp = 1; \ ) -#define REXEC_FBC_CLASS_SCAN(CoNd) \ -REXEC_FBC_SCAN( \ - if (CoNd) { \ - if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \ - goto got_it; \ - else \ - tmp = doevery; \ - } \ - else \ - tmp = 1; \ +#define REXEC_FBC_CLASS_SCAN(COND) \ +REXEC_FBC_SCAN( /* Loops while (s < strend) */ \ + if (COND) { \ + if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \ + goto got_it; \ + else \ + tmp = doevery; \ + } \ + else \ + tmp = 1; \ ) -#define REXEC_FBC_TRYIT \ -if ((reginfo->intuit || regtry(reginfo, &s))) \ - goto got_it - -#define REXEC_FBC_CSCAN(CoNdUtF8,CoNd) \ +#define REXEC_FBC_CSCAN(CONDUTF8,COND) \ if (utf8_target) { \ - REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \ + REXEC_FBC_UTF8_CLASS_SCAN(CONDUTF8); \ } \ else { \ - REXEC_FBC_CLASS_SCAN(CoNd); \ + REXEC_FBC_CLASS_SCAN(COND); \ } - -#define DUMP_EXEC_POS(li,s,doutf8) \ - dump_exec_pos(li,s,(reginfo->strend),(reginfo->strbeg), \ - startpos, doutf8) - -#define UTF8_NOLOAD(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \ - tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n'; \ - tmp = TEST_NON_UTF8(tmp); \ - REXEC_FBC_UTF8_SCAN( \ - if (tmp == ! TEST_NON_UTF8((U8) *s)) { \ - tmp = !tmp; \ - IF_SUCCESS; \ - } \ - else { \ - IF_FAIL; \ - } \ - ); \ - -#define UTF8_LOAD(TeSt1_UtF8, TeSt2_UtF8, IF_SUCCESS, IF_FAIL) \ - if (s == reginfo->strbeg) { \ - tmp = '\n'; \ - } \ - else { \ - U8 * const r = reghop3((U8*)s, -1, (U8*)reginfo->strbeg); \ - tmp = utf8n_to_uvchr(r, (U8*) reginfo->strend - r, \ +/* The three macros below are slightly different versions of the same logic. + * + * The first is for /a and /aa when the target string is UTF-8. This can only + * match ascii, but it must advance based on UTF-8. The other two handle the + * non-UTF-8 and the more generic UTF-8 cases. In all three, we are looking + * for the boundary (or non-boundary) between a word and non-word character. + * The utf8 and non-utf8 cases have the same logic, but the details must be + * different. Find the "wordness" of the character just prior to this one, and + * compare it with the wordness of this one. If they differ, we have a + * boundary. At the beginning of the string, pretend that the previous + * character was a new-line. + * + * All these macros uncleanly have side-effects with each other and outside + * variables. So far it's been too much trouble to clean-up + * + * TEST_NON_UTF8 is the macro or function to call to test if its byte input is + * a word character or not. + * IF_SUCCESS is code to do if it finds that we are at a boundary between + * word/non-word + * IF_FAIL is code to do if we aren't at a boundary between word/non-word + * + * Exactly one of the two IF_FOO parameters is a no-op, depending on whether we + * are looking for a boundary or for a non-boundary. If we are looking for a + * boundary, we want IF_FAIL to be the no-op, and for IF_SUCCESS to go out and + * see if this tentative match actually works, and if so, to quit the loop + * here. And vice-versa if we are looking for a non-boundary. + * + * 'tmp' below in the next three macros in the REXEC_FBC_SCAN and + * REXEC_FBC_UTF8_SCAN loops is a loop invariant, a bool giving the return of + * TEST_NON_UTF8(s-1). To see this, note that that's what it is defined to be + * at entry to the loop, and to get to the IF_FAIL branch, tmp must equal + * TEST_NON_UTF8(s), and in the opposite branch, IF_SUCCESS, tmp is that + * complement. But in that branch we complement tmp, meaning that at the + * bottom of the loop tmp is always going to be equal to TEST_NON_UTF8(s), + * which means at the top of the loop in the next iteration, it is + * TEST_NON_UTF8(s-1) */ +#define FBC_UTF8_A(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \ + tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n'; \ + tmp = TEST_NON_UTF8(tmp); \ + REXEC_FBC_UTF8_SCAN( /* advances s while s < strend */ \ + if (tmp == ! TEST_NON_UTF8((U8) *s)) { \ + tmp = !tmp; \ + IF_SUCCESS; /* Is a boundary if values for s-1 and s differ */ \ + } \ + else { \ + IF_FAIL; \ + } \ + ); \ + +/* Like FBC_UTF8_A, but TEST_UV is a macro which takes a UV as its input, and + * TEST_UTF8 is a macro that for the same input code points returns identically + * to TEST_UV, but takes a pointer to a UTF-8 encoded string instead */ +#define FBC_UTF8(TEST_UV, TEST_UTF8, IF_SUCCESS, IF_FAIL) \ + if (s == reginfo->strbeg) { \ + tmp = '\n'; \ + } \ + else { /* Back-up to the start of the previous character */ \ + U8 * const r = reghop3((U8*)s, -1, (U8*)reginfo->strbeg); \ + tmp = utf8n_to_uvchr(r, (U8*) reginfo->strend - r, \ 0, UTF8_ALLOW_DEFAULT); \ - } \ - tmp = TeSt1_UtF8; \ - LOAD_UTF8_CHARCLASS_ALNUM(); \ - REXEC_FBC_UTF8_SCAN( \ - if (tmp == ! (TeSt2_UtF8)) { \ - tmp = !tmp; \ - IF_SUCCESS; \ - } \ - else { \ - IF_FAIL; \ - } \ - ); \ + } \ + tmp = TEST_UV(tmp); \ + LOAD_UTF8_CHARCLASS_ALNUM(); \ + REXEC_FBC_UTF8_SCAN( /* advances s while s < strend */ \ + if (tmp == ! (TEST_UTF8((U8 *) s))) { \ + tmp = !tmp; \ + IF_SUCCESS; \ + } \ + else { \ + IF_FAIL; \ + } \ + ); -/* The only difference between the BOUND and NBOUND cases is that - * REXEC_FBC_TRYIT is called when matched in BOUND, and when non-matched in - * NBOUND. This is accomplished by passing it in either the if or else clause, - * with the other one being empty */ -#define FBC_BOUND(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \ - FBC_BOUND_COMMON(UTF8_LOAD(TEST1_UTF8, TEST2_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER) - -#define FBC_BOUND_NOLOAD(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \ - FBC_BOUND_COMMON(UTF8_NOLOAD(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER) - -#define FBC_NBOUND(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \ - FBC_BOUND_COMMON(UTF8_LOAD(TEST1_UTF8, TEST2_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT) - -#define FBC_NBOUND_NOLOAD(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \ - FBC_BOUND_COMMON(UTF8_NOLOAD(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT) - - -/* Common to the BOUND and NBOUND cases. Unfortunately the UTF8 tests need to - * be passed in completely with the variable name being tested, which isn't - * such a clean interface, but this is easier to read than it was before. We - * are looking for the boundary (or non-boundary between a word and non-word - * character. The utf8 and non-utf8 cases have the same logic, but the details - * must be different. Find the "wordness" of the character just prior to this - * one, and compare it with the wordness of this one. If they differ, we have - * a boundary. At the beginning of the string, pretend that the previous - * character was a new-line */ +/* Like the above two macros. UTF8_CODE is the complete code for handling + * UTF-8. Common to the BOUND and NBOUND cases, set-up by the FBC_BOUND, etc + * macros below */ #define FBC_BOUND_COMMON(UTF8_CODE, TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \ if (utf8_target) { \ - UTF8_CODE \ + UTF8_CODE \ } \ else { /* Not utf8 */ \ tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n'; \ tmp = TEST_NON_UTF8(tmp); \ - REXEC_FBC_SCAN( \ + REXEC_FBC_SCAN( /* advances s while s < strend */ \ if (tmp == ! TEST_NON_UTF8((U8) *s)) { \ - tmp = !tmp; \ IF_SUCCESS; \ + tmp = !tmp; \ } \ else { \ IF_FAIL; \ } \ ); \ } \ - if ((!prog->minlen && tmp) && (reginfo->intuit || regtry(reginfo, &s))) \ - goto got_it; + /* Here, things have been set up by the previous code so that tmp is the \ + * return of TEST_NON_UTF(s-1) or TEST_UTF8(s-1) (depending on the \ + * utf8ness of the target). We also have to check if this matches against \ + * the EOS, which we treat as a \n (which is the same value in both UTF-8 \ + * or non-UTF8, so can use the non-utf8 test condition even for a UTF-8 \ + * string */ \ + if (tmp == ! TEST_NON_UTF8('\n')) { \ + IF_SUCCESS; \ + } \ + else { \ + IF_FAIL; \ + } + +/* This is the macro to use when we want to see if something that looks like it + * could match, actually does, and if so exits the loop */ +#define REXEC_FBC_TRYIT \ + if ((reginfo->intuit || regtry(reginfo, &s))) \ + goto got_it + +/* The only difference between the BOUND and NBOUND cases is that + * REXEC_FBC_TRYIT is called when matched in BOUND, and when non-matched in + * NBOUND. This is accomplished by passing it as either the if or else clause, + * with the other one being empty (PLACEHOLDER is defined as empty). + * + * The TEST_FOO parameters are for operating on different forms of input, but + * all should be ones that return identically for the same underlying code + * points */ +#define FBC_BOUND(TEST_NON_UTF8, TEST_UV, TEST_UTF8) \ + FBC_BOUND_COMMON( \ + FBC_UTF8(TEST_UV, TEST_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), \ + TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER) + +#define FBC_BOUND_A(TEST_NON_UTF8, TEST_UV, TEST_UTF8) \ + FBC_BOUND_COMMON( \ + FBC_UTF8_A(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), \ + TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER) + +#define FBC_NBOUND(TEST_NON_UTF8, TEST_UV, TEST_UTF8) \ + FBC_BOUND_COMMON( \ + FBC_UTF8(TEST_UV, TEST_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), \ + TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT) + +#define FBC_NBOUND_A(TEST_NON_UTF8, TEST_UV, TEST_UTF8) \ + FBC_BOUND_COMMON( \ + FBC_UTF8_A(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), \ + TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT) + /* We know what class REx starts with. Try to find this position... */ /* if reginfo->intuit, its a dryrun */ /* annoyingly all the vars in this routine have different names from their counterparts in regmatch. /grrr */ - STATIC char * S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, const char *strend, regmatch_info *reginfo) @@ -1846,45 +1898,30 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, } break; } + case BOUNDL: - FBC_BOUND(isWORDCHAR_LC, - isWORDCHAR_LC_uvchr(tmp), - isWORDCHAR_LC_utf8((U8*)s)); + FBC_BOUND(isWORDCHAR_LC, isWORDCHAR_LC_uvchr, isWORDCHAR_LC_utf8); break; case NBOUNDL: - FBC_NBOUND(isWORDCHAR_LC, - isWORDCHAR_LC_uvchr(tmp), - isWORDCHAR_LC_utf8((U8*)s)); + FBC_NBOUND(isWORDCHAR_LC, isWORDCHAR_LC_uvchr, isWORDCHAR_LC_utf8); break; case BOUND: - FBC_BOUND(isWORDCHAR, - isWORDCHAR_uni(tmp), - cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target))); + FBC_BOUND(isWORDCHAR, isWORDCHAR_uni, isWORDCHAR_utf8); break; case BOUNDA: - FBC_BOUND_NOLOAD(isWORDCHAR_A, - isWORDCHAR_A(tmp), - isWORDCHAR_A((U8*)s)); + FBC_BOUND_A(isWORDCHAR_A, isWORDCHAR_A, isWORDCHAR_A); break; case NBOUND: - FBC_NBOUND(isWORDCHAR, - isWORDCHAR_uni(tmp), - cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target))); + FBC_NBOUND(isWORDCHAR, isWORDCHAR_uni, isWORDCHAR_utf8); break; case NBOUNDA: - FBC_NBOUND_NOLOAD(isWORDCHAR_A, - isWORDCHAR_A(tmp), - isWORDCHAR_A((U8*)s)); + FBC_NBOUND_A(isWORDCHAR_A, isWORDCHAR_A, isWORDCHAR_A); break; case BOUNDU: - FBC_BOUND(isWORDCHAR_L1, - isWORDCHAR_uni(tmp), - cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target))); + FBC_BOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8); break; case NBOUNDU: - FBC_NBOUND(isWORDCHAR_L1, - isWORDCHAR_uni(tmp), - cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target))); + FBC_NBOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8); break; case LNBREAK: REXEC_FBC_CSCAN(is_LNBREAK_utf8_safe(s, strend), @@ -2433,7 +2470,6 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, /* flags: For optimizations. See REXEC_* in regexp.h */ { - dVAR; struct regexp *const prog = ReANY(rx); char *s; regnode *c; @@ -3154,7 +3190,6 @@ phooey: STATIC I32 /* 0 failure, 1 success */ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) { - dVAR; CHECKPOINT lastcp; REGEXP *const rx = reginfo->prog; regexp *const prog = ReANY(rx); @@ -5283,7 +5318,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) assert(o->op_targ == OP_LEAVE); o = cUNOPo->op_first; assert(o->op_type == OP_ENTER); - o = o->op_sibling; + o = OP_SIBLING(o); } if (o->op_type != OP_STUB) { @@ -5756,11 +5791,14 @@ NULL { /* see the discussion above about CURLYX/WHILEM */ I32 n; - int min = ARG1(cur_curlyx->u.curlyx.me); - int max = ARG2(cur_curlyx->u.curlyx.me); - regnode *A = NEXTOPER(cur_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS; + int min, max; + regnode *A; assert(cur_curlyx); /* keep Coverity happy */ + + min = ARG1(cur_curlyx->u.curlyx.me); + max = ARG2(cur_curlyx->u.curlyx.me); + A = NEXTOPER(cur_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS; n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */ ST.save_lastloc = cur_curlyx->u.curlyx.lastloc; ST.cache_offset = 0; @@ -6150,6 +6188,7 @@ NULL /* calculate c1 and c2 for possible match of 1st char * following curly */ ST.c1 = ST.c2 = CHRTEST_VOID; + assert(ST.B); if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) { regnode *text_node = ST.B; if (! HAS_TEXT(text_node)) @@ -7035,7 +7074,6 @@ STATIC I32 S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, regmatch_info *const reginfo, I32 max, int depth) { - dVAR; char *scan; /* Pointer to current position in target string */ I32 c; char *loceol = reginfo->strend; /* local version */ @@ -7576,7 +7614,6 @@ Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog, * swash are returned (in a printable form). * Tied intimately to how regcomp.c sets up the data structure */ - dVAR; SV *sw = NULL; SV *si = NULL; /* Input swash initialization string */ SV* invlist = NULL; @@ -7839,8 +7876,6 @@ S_reghop3(U8 *s, SSize_t off, const U8* lim) * 'off' >= 0, backwards if negative. But don't go outside of position * 'lim', which better be < s if off < 0 */ - dVAR; - PERL_ARGS_ASSERT_REGHOP3; if (off >= 0) { @@ -7865,8 +7900,6 @@ S_reghop3(U8 *s, SSize_t off, const U8* lim) STATIC U8 * S_reghop4(U8 *s, SSize_t off, const U8* llim, const U8* rlim) { - dVAR; - PERL_ARGS_ASSERT_REGHOP4; if (off >= 0) { @@ -7894,8 +7927,6 @@ S_reghop4(U8 *s, SSize_t off, const U8* llim, const U8* rlim) STATIC U8 * S_reghopmaybe3(U8* s, SSize_t off, const U8* lim) { - dVAR; - PERL_ARGS_ASSERT_REGHOPMAYBE3; if (off >= 0) { @@ -8012,7 +8043,6 @@ S_setup_eval_state(pTHX_ regmatch_info *const reginfo) static void S_cleanup_regmatch_info_aux(pTHX_ void *arg) { - dVAR; regmatch_info_aux *aux = (regmatch_info_aux *) arg; regmatch_info_aux_eval *eval_state = aux->info_aux_eval; regmatch_slab *s; @@ -8104,7 +8134,6 @@ S_to_byte_substr(pTHX_ regexp *prog) /* Converts substr fields in prog from UTF-8 to bytes, calling fbm_compile * on the converted value; returns FALSE if can't be converted. */ - dVAR; int i = 1; PERL_ARGS_ASSERT_TO_BYTE_SUBSTR; diff --git a/run.c b/run.c index ff3bc93..8f0224a 100644 --- a/run.c +++ b/run.c @@ -36,7 +36,6 @@ int Perl_runops_standard(pTHX) { - dVAR; OP *op = PL_op; OP_ENTRY_PROBE(OP_NAME(op)); while ((PL_op = op = op->op_ppaddr(aTHX))) { diff --git a/scope.c b/scope.c index 76e023a..5cfd78b 100644 --- a/scope.c +++ b/scope.c @@ -29,8 +29,6 @@ SV** Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n) { - dVAR; - PERL_ARGS_ASSERT_STACK_GROW; PL_stack_sp = sp; @@ -51,7 +49,6 @@ Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n) PERL_SI * Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems) { - dVAR; PERL_SI *si; Newx(si, 1, PERL_SI); si->si_stack = newAV(); @@ -74,7 +71,6 @@ Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems) I32 Perl_cxinc(pTHX) { - dVAR; const IV old_max = cxstack_max; cxstack_max = GROW(cxstack_max); Renew(cxstack, cxstack_max + 1, PERL_CONTEXT); @@ -87,7 +83,6 @@ Perl_cxinc(pTHX) void Perl_push_scope(pTHX) { - dVAR; if (UNLIKELY(PL_scopestack_ix == PL_scopestack_max)) { PL_scopestack_max = GROW(PL_scopestack_max); Renew(PL_scopestack, PL_scopestack_max, I32); @@ -105,7 +100,6 @@ Perl_push_scope(pTHX) void Perl_pop_scope(pTHX) { - dVAR; const I32 oldsave = PL_scopestack[--PL_scopestack_ix]; LEAVE_SCOPE(oldsave); } @@ -113,7 +107,6 @@ Perl_pop_scope(pTHX) I32 * Perl_markstack_grow(pTHX) { - dVAR; const I32 oldmax = PL_markstack_max - PL_markstack; const I32 newmax = GROW(oldmax); @@ -126,7 +119,6 @@ Perl_markstack_grow(pTHX) void Perl_savestack_grow(pTHX) { - dVAR; PL_savestack_max = GROW(PL_savestack_max) + 4; Renew(PL_savestack, PL_savestack_max, ANY); } @@ -134,7 +126,6 @@ Perl_savestack_grow(pTHX) void Perl_savestack_grow_cnt(pTHX_ I32 need) { - dVAR; PL_savestack_max = PL_savestack_ix + need; Renew(PL_savestack, PL_savestack_max, ANY); } @@ -144,7 +135,6 @@ Perl_savestack_grow_cnt(pTHX_ I32 need) void Perl_tmps_grow(pTHX_ SSize_t n) { - dVAR; #ifndef STRESS_REALLOC if (n < 128) n = (PL_tmps_max < 512) ? 128 : 512; @@ -157,7 +147,6 @@ Perl_tmps_grow(pTHX_ SSize_t n) void Perl_free_tmps(pTHX) { - dVAR; /* XXX should tmps_floor live in cxstack? */ const SSize_t myfloor = PL_tmps_floor; while (PL_tmps_ix > myfloor) { /* clean up after last statement */ @@ -175,7 +164,6 @@ Perl_free_tmps(pTHX) STATIC SV * S_save_scalar_at(pTHX_ SV **sptr, const U32 flags) { - dVAR; SV * osv; SV *sv; @@ -199,7 +187,6 @@ S_save_scalar_at(pTHX_ SV **sptr, const U32 flags) void Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type) { - dVAR; dSS_ADD; SS_ADD_PTR(ptr1); SS_ADD_PTR(ptr2); @@ -210,7 +197,6 @@ Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type) SV * Perl_save_scalar(pTHX_ GV *gv) { - dVAR; SV ** const sptr = &GvSVn(gv); PERL_ARGS_ASSERT_SAVE_SCALAR; @@ -229,8 +215,6 @@ Perl_save_scalar(pTHX_ GV *gv) void Perl_save_generic_svref(pTHX_ SV **sptr) { - dVAR; - PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF; save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_GENERIC_SVREF); @@ -242,8 +226,6 @@ Perl_save_generic_svref(pTHX_ SV **sptr) void Perl_save_generic_pvref(pTHX_ char **str) { - dVAR; - PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF; save_pushptrptr(*str, str, SAVEt_GENERIC_PVREF); @@ -255,8 +237,6 @@ Perl_save_generic_pvref(pTHX_ char **str) void Perl_save_shared_pvref(pTHX_ char **str) { - dVAR; - PERL_ARGS_ASSERT_SAVE_SHARED_PVREF; save_pushptrptr(str, *str, SAVEt_SHARED_PVREF); @@ -267,7 +247,6 @@ Perl_save_shared_pvref(pTHX_ char **str) void Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val) { - dVAR; dSS_ADD; PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS; @@ -282,8 +261,6 @@ Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val) void Perl_save_gp(pTHX_ GV *gv, I32 empty) { - dVAR; - PERL_ARGS_ASSERT_SAVE_GP; save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP); @@ -316,7 +293,6 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty) AV * Perl_save_ary(pTHX_ GV *gv) { - dVAR; AV * const oav = GvAVn(gv); AV *av; @@ -336,7 +312,6 @@ Perl_save_ary(pTHX_ GV *gv) HV * Perl_save_hash(pTHX_ GV *gv) { - dVAR; HV *ohv, *hv; PERL_ARGS_ASSERT_SAVE_HASH; @@ -355,7 +330,6 @@ Perl_save_hash(pTHX_ GV *gv) void Perl_save_item(pTHX_ SV *item) { - dVAR; SV * const sv = newSVsv(item); PERL_ARGS_ASSERT_SAVE_ITEM; @@ -368,7 +342,6 @@ Perl_save_item(pTHX_ SV *item) void Perl_save_bool(pTHX_ bool *boolp) { - dVAR; dSS_ADD; PERL_ARGS_ASSERT_SAVE_BOOL; @@ -381,7 +354,6 @@ Perl_save_bool(pTHX_ bool *boolp) void Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type) { - dVAR; dSS_ADD; SS_ADD_INT(i); @@ -393,7 +365,6 @@ Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type) void Perl_save_int(pTHX_ int *intp) { - dVAR; const int i = *intp; UV type = ((UV)((UV)i << SAVE_TIGHT_SHIFT) | SAVEt_INT_SMALL); int size = 2; @@ -414,7 +385,6 @@ Perl_save_int(pTHX_ int *intp) void Perl_save_I8(pTHX_ I8 *bytep) { - dVAR; dSS_ADD; PERL_ARGS_ASSERT_SAVE_I8; @@ -427,7 +397,6 @@ Perl_save_I8(pTHX_ I8 *bytep) void Perl_save_I16(pTHX_ I16 *intp) { - dVAR; dSS_ADD; PERL_ARGS_ASSERT_SAVE_I16; @@ -440,7 +409,6 @@ Perl_save_I16(pTHX_ I16 *intp) void Perl_save_I32(pTHX_ I32 *intp) { - dVAR; const I32 i = *intp; UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_I32_SMALL); int size = 2; @@ -461,7 +429,6 @@ Perl_save_I32(pTHX_ I32 *intp) void Perl_save_strlen(pTHX_ STRLEN *ptr) { - dVAR; dSS_ADD; PERL_ARGS_ASSERT_SAVE_STRLEN; @@ -478,8 +445,6 @@ Perl_save_strlen(pTHX_ STRLEN *ptr) void Perl_save_pptr(pTHX_ char **pptr) { - dVAR; - PERL_ARGS_ASSERT_SAVE_PPTR; save_pushptrptr(*pptr, pptr, SAVEt_PPTR); @@ -488,8 +453,6 @@ Perl_save_pptr(pTHX_ char **pptr) void Perl_save_vptr(pTHX_ void *ptr) { - dVAR; - PERL_ARGS_ASSERT_SAVE_VPTR; save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR); @@ -498,8 +461,6 @@ Perl_save_vptr(pTHX_ void *ptr) void Perl_save_sptr(pTHX_ SV **sptr) { - dVAR; - PERL_ARGS_ASSERT_SAVE_SPTR; save_pushptrptr(*sptr, sptr, SAVEt_SPTR); @@ -508,7 +469,6 @@ Perl_save_sptr(pTHX_ SV **sptr) void Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off) { - dVAR; dSS_ADD; ASSERT_CURPAD_ACTIVE("save_padsv"); @@ -522,8 +482,6 @@ Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off) void Perl_save_hptr(pTHX_ HV **hptr) { - dVAR; - PERL_ARGS_ASSERT_SAVE_HPTR; save_pushptrptr(*hptr, hptr, SAVEt_HPTR); @@ -532,8 +490,6 @@ Perl_save_hptr(pTHX_ HV **hptr) void Perl_save_aptr(pTHX_ AV **aptr) { - dVAR; - PERL_ARGS_ASSERT_SAVE_APTR; save_pushptrptr(*aptr, aptr, SAVEt_APTR); @@ -542,7 +498,6 @@ Perl_save_aptr(pTHX_ AV **aptr) void Perl_save_pushptr(pTHX_ void *const ptr, const int type) { - dVAR; dSS_ADD; SS_ADD_PTR(ptr); SS_ADD_UV(type); @@ -552,7 +507,6 @@ Perl_save_pushptr(pTHX_ void *const ptr, const int type) void Perl_save_clearsv(pTHX_ SV **svp) { - dVAR; const UV offset = svp - PL_curpad; const UV offset_shifted = offset << SAVE_TIGHT_SHIFT; @@ -575,8 +529,6 @@ Perl_save_clearsv(pTHX_ SV **svp) void Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen) { - dVAR; - PERL_ARGS_ASSERT_SAVE_DELETE; save_pushptri32ptr(key, klen, SvREFCNT_inc_simple(hv), SAVEt_DELETE); @@ -600,7 +552,6 @@ Perl_save_hdelete(pTHX_ HV *hv, SV *keysv) void Perl_save_adelete(pTHX_ AV *av, SSize_t key) { - dVAR; dSS_ADD; PERL_ARGS_ASSERT_SAVE_ADELETE; @@ -615,9 +566,7 @@ Perl_save_adelete(pTHX_ AV *av, SSize_t key) void Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p) { - dVAR; dSS_ADD; - PERL_ARGS_ASSERT_SAVE_DESTRUCTOR; SS_ADD_DPTR(f); @@ -629,7 +578,6 @@ Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p) void Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p) { - dVAR; dSS_ADD; SS_ADD_DXPTR(f); @@ -641,7 +589,6 @@ Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p) void Perl_save_hints(pTHX) { - dVAR; COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling)); if (PL_hints & HINT_LOCALIZE_HH) { HV *oldhh = GvHV(PL_hintgv); @@ -669,7 +616,7 @@ void Perl_save_aelem_flags(pTHX_ AV *av, SSize_t idx, SV **sptr, const U32 flags) { - dVAR; dSS_ADD; + dSS_ADD; SV *sv; PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS; @@ -699,7 +646,6 @@ Perl_save_aelem_flags(pTHX_ AV *av, SSize_t idx, SV **sptr, void Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags) { - dVAR; SV *sv; PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS; @@ -728,8 +674,6 @@ Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags) SV* Perl_save_svref(pTHX_ SV **sptr) { - dVAR; - PERL_ARGS_ASSERT_SAVE_SVREF; SvGETMAGIC(*sptr); @@ -740,7 +684,6 @@ Perl_save_svref(pTHX_ SV **sptr) I32 Perl_save_alloc(pTHX_ I32 size, I32 pad) { - dVAR; const I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix] - (char*)PL_savestack); const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack)); @@ -786,8 +729,6 @@ Perl_save_alloc(pTHX_ I32 size, I32 pad) void Perl_leave_scope(pTHX_ I32 base) { - dVAR; - /* Localise the effects of the TAINT_NOT inside the loop. */ bool was = TAINT_get; @@ -1288,8 +1229,6 @@ Perl_leave_scope(pTHX_ I32 base) void Perl_cx_dump(pTHX_ PERL_CONTEXT *cx) { - dVAR; - PERL_ARGS_ASSERT_CX_DUMP; #ifdef DEBUGGING diff --git a/sv.c b/sv.c index e0b08d0..b02ef28 100644 --- a/sv.c +++ b/sv.c @@ -310,7 +310,6 @@ Public API: STATIC SV* S_more_sv(pTHX) { - dVAR; SV* sv; char *chunk; /* must use New here to match call to */ Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */ @@ -432,7 +431,6 @@ and split it into a list of free SVs. static void S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) { - dVAR; SV *const sva = MUTABLE_SV(ptr); SV* sv; SV* svend; @@ -472,7 +470,6 @@ S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) STATIC I32 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) { - dVAR; SV* sva; I32 visited = 0; @@ -531,7 +528,6 @@ Perl_sv_report_used(pTHX) static void do_clean_objs(pTHX_ SV *const ref) { - dVAR; assert (SvROK(ref)); { SV * const target = SvRV(ref); @@ -557,7 +553,6 @@ do_clean_objs(pTHX_ SV *const ref) static void do_clean_named_objs(pTHX_ SV *const sv) { - dVAR; SV *obj; assert(SvTYPE(sv) == SVt_PVGV); assert(isGV_with_GP(sv)); @@ -601,7 +596,6 @@ do_clean_named_objs(pTHX_ SV *const sv) static void do_clean_named_io_objs(pTHX_ SV *const sv) { - dVAR; SV *obj; assert(SvTYPE(sv) == SVt_PVGV); assert(isGV_with_GP(sv)); @@ -638,7 +632,6 @@ Attempt to destroy all objects not yet freed. void Perl_sv_clean_objs(pTHX) { - dVAR; GV *olddef, *olderr; PL_in_clean_objs = TRUE; visit(do_clean_objs, SVf_ROK, SVf_ROK); @@ -667,7 +660,6 @@ Perl_sv_clean_objs(pTHX) static void do_clean_all(pTHX_ SV *const sv) { - dVAR; if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) { /* don't clean pid table and strtab */ return; @@ -690,7 +682,6 @@ SVs which are in complex self-referential hierarchies. I32 Perl_sv_clean_all(pTHX) { - dVAR; I32 cleaned; PL_in_clean_all = TRUE; cleaned = visit(do_clean_all, 0,0); @@ -746,7 +737,6 @@ heads and bodies within the arenas must already have been freed. void Perl_sv_free_arenas(pTHX) { - dVAR; SV* sva; SV* svanext; unsigned int i; @@ -814,6 +804,8 @@ Perl_sv_free_arenas(pTHX) =head1 SV-Body Allocation +=cut + Allocation of SV-bodies is similar to SV-heads, differing as follows; the allocation mechanism is used for many body types, so is somewhat more complicated, it uses arena-sets, and has no need for still-live @@ -1074,7 +1066,6 @@ void * Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, const size_t arena_size) { - dVAR; void ** const root = &PL_body_roots[sv_type]; struct arena_desc *adesc; struct arena_set *aroot = (struct arena_set *) PL_body_arenas; @@ -1082,6 +1073,9 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, char *start; const char *end; const size_t good_arena_size = Perl_malloc_good_size(arena_size); +#if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT) + dVAR; +#endif #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) static bool done_sanity_check; @@ -1180,7 +1174,6 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, STATIC void * S_new_body(pTHX_ const svtype sv_type) { - dVAR; void *xpv; new_body_inline(xpv, sv_type); return xpv; @@ -1207,7 +1200,6 @@ C. void Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) { - dVAR; void* old_body; void* new_body; const svtype old_type = SvTYPE(sv); @@ -1507,13 +1499,12 @@ wrapper instead. */ int -Perl_sv_backoff(pTHX_ SV *const sv) +Perl_sv_backoff(SV *const sv) { STRLEN delta; const char * const s = SvPVX_const(sv); PERL_ARGS_ASSERT_SV_BACKOFF; - PERL_UNUSED_CONTEXT; assert(SvOOK(sv)); assert(SvTYPE(sv) != SVt_PVHV); @@ -1628,8 +1619,6 @@ Does not handle 'set' magic. See also C. void Perl_sv_setiv(pTHX_ SV *const sv, const IV i) { - dVAR; - PERL_ARGS_ASSERT_SV_SETIV; SV_CHECK_THINKFIRST_COW_DROP(sv); @@ -1740,8 +1729,6 @@ Does not handle 'set' magic. See also C. void Perl_sv_setnv(pTHX_ SV *const sv, const NV num) { - dVAR; - PERL_ARGS_ASSERT_SV_SETNV; SV_CHECK_THINKFIRST_COW_DROP(sv); @@ -1790,26 +1777,24 @@ Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num) SvSETMAGIC(sv); } -/* Print an "isn't numeric" warning, using a cleaned-up, - * printable version of the offending string +/* Return a cleaned-up, printable version of sv, for non-numeric, or + * not incrementable warning display. + * Originally part of S_not_a_number(). + * The return value may be != tmpbuf. */ -STATIC void -S_not_a_number(pTHX_ SV *const sv) -{ - dVAR; - SV *dsv; - char tmpbuf[64]; - const char *pv; +STATIC const char * +S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) { + const char *pv; - PERL_ARGS_ASSERT_NOT_A_NUMBER; + PERL_ARGS_ASSERT_SV_DISPLAY; if (DO_UTF8(sv)) { - dsv = newSVpvs_flags("", SVs_TEMP); + SV *dsv = newSVpvs_flags("", SVs_TEMP); pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT); } else { char *d = tmpbuf; - const char * const limit = tmpbuf + sizeof(tmpbuf) - 8; + const char * const limit = tmpbuf + tmpbuf_size - 8; /* each *s can expand to 4 chars + "...\0", i.e. need room for 8 chars */ @@ -1860,6 +1845,24 @@ S_not_a_number(pTHX_ SV *const sv) pv = tmpbuf; } + return pv; +} + +/* Print an "isn't numeric" warning, using a cleaned-up, + * printable version of the offending string + */ + +STATIC void +S_not_a_number(pTHX_ SV *const sv) +{ + dVAR; + char tmpbuf[64]; + const char *pv; + + PERL_ARGS_ASSERT_NOT_A_NUMBER; + + pv = sv_display(sv, tmpbuf, sizeof(tmpbuf)); + if (PL_op) Perl_warner(aTHX_ packWARN(WARN_NUMERIC), /* diag_listed_as: Argument "%s" isn't numeric%s */ @@ -1871,6 +1874,20 @@ S_not_a_number(pTHX_ SV *const sv) "Argument \"%s\" isn't numeric", pv); } +STATIC void +S_not_incrementable(pTHX_ SV *const sv) { + dVAR; + char tmpbuf[64]; + const char *pv; + + PERL_ARGS_ASSERT_NOT_INCREMENTABLE; + + pv = sv_display(sv, tmpbuf, sizeof(tmpbuf)); + + Perl_warner(aTHX_ packWARN(WARN_NUMERIC), + "Argument \"%s\" treated as 0 in increment (++)", pv); +} + /* =for apidoc looks_like_number @@ -2007,9 +2024,8 @@ S_sv_2iuv_non_preserve(pTHX_ SV *const sv # endif ) { - dVAR; - PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE; + PERL_UNUSED_CONTEXT; DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { @@ -2058,8 +2074,6 @@ S_sv_2iuv_non_preserve(pTHX_ SV *const sv STATIC bool S_sv_2iuv_common(pTHX_ SV *const sv) { - dVAR; - PERL_ARGS_ASSERT_SV_2IUV_COMMON; if (SvNOKp(sv)) { @@ -2336,8 +2350,6 @@ Normally used via the C and C macros. IV Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) { - dVAR; - PERL_ARGS_ASSERT_SV_2IV_FLAGS; assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV @@ -2431,8 +2443,6 @@ Normally used via the C and C macros. UV Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) { - dVAR; - PERL_ARGS_ASSERT_SV_2UV_FLAGS; if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) @@ -2513,8 +2523,6 @@ Normally used via the C and C macros. NV Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) { - dVAR; - PERL_ARGS_ASSERT_SV_2NV_FLAGS; assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV @@ -2816,7 +2824,6 @@ C and C usually end up here too. char * Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) { - dVAR; char *s; PERL_ARGS_ASSERT_SV_2PV_FLAGS; @@ -3187,8 +3194,6 @@ contain SV_GMAGIC, then it does an mg_get() first. bool Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags) { - dVAR; - PERL_ARGS_ASSERT_SV_2BOOL_FLAGS; restart: @@ -3304,8 +3309,6 @@ especially if it could return the position of the first one. STRLEN Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra) { - dVAR; - PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW; if (sv == &PL_sv_undef) @@ -3564,8 +3567,6 @@ use the Encode extension for that. bool Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok) { - dVAR; - PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE; if (SvPOKp(sv) && SvUTF8(sv)) { @@ -4103,7 +4104,6 @@ S_sv_buf_to_rw(pTHX_ SV *sv) void Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) { - dVAR; U32 sflags; int dtype; svtype stype; @@ -4703,7 +4703,6 @@ undefined. Does not handle 'set' magic. See C. void Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len) { - dVAR; char *dptr; PERL_ARGS_ASSERT_SV_SETPVN; @@ -4761,7 +4760,6 @@ Does not handle 'set' magic. See C. void Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr) { - dVAR; STRLEN len; PERL_ARGS_ASSERT_SV_SETPV; @@ -4802,8 +4800,6 @@ Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr) void Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek) { - dVAR; - PERL_ARGS_ASSERT_SV_SETHEK; if (!hek) { @@ -4873,7 +4869,6 @@ C, and already meets the requirements for storing in C). void Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags) { - dVAR; STRLEN allocate; PERL_ARGS_ASSERT_SV_USEPVN_FLAGS; @@ -4996,8 +4991,6 @@ of. Hence, it croaks on read-only values. static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags) { - dVAR; - assert(SvIsCOW(sv)); { #ifdef PERL_ANY_COW @@ -5270,7 +5263,6 @@ in terms of this function. void Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags) { - dVAR; STRLEN dlen; const char * const dstr = SvPV_force_flags(dsv, dlen, flags); @@ -5336,8 +5328,6 @@ and C are implemented in terms of this function. void Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags) { - dVAR; - PERL_ARGS_ASSERT_SV_CATSV_FLAGS; if (ssv) { @@ -5367,7 +5357,6 @@ valid UTF-8. Handles 'get' magic, but not 'set' magic. See C. void Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr) { - dVAR; STRLEN len; STRLEN tlen; char *junk; @@ -5443,7 +5432,6 @@ modules supporting older perls. SV * Perl_newSV(pTHX_ const STRLEN len) { - dVAR; SV *sv; new_SV(sv); @@ -5476,7 +5464,6 @@ MAGIC * Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, const MGVTBL *const vtable, const char *const name, const I32 namlen) { - dVAR; MAGIC* mg; PERL_ARGS_ASSERT_SV_MAGICEXT; @@ -5584,7 +5571,6 @@ void Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, const char *const name, const I32 namlen) { - dVAR; const MGVTBL *vtable; MAGIC* mg; unsigned int flags; @@ -5791,7 +5777,6 @@ Perl_sv_rvweaken(pTHX_ SV *const sv) void Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) { - dVAR; SV **svp; AV *av = NULL; MAGIC *mg = NULL; @@ -5852,7 +5837,6 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) void Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) { - dVAR; SV **svp = NULL; PERL_ARGS_ASSERT_SV_DEL_BACKREF; @@ -6074,7 +6058,6 @@ C that applies to C. void Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags) { - dVAR; char *big; char *mid; char *midend; @@ -6172,7 +6155,6 @@ time you'll want to use C or one of its many macro front-ends. void Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv) { - dVAR; const U32 refcnt = SvREFCNT(sv); PERL_ARGS_ASSERT_SV_REPLACE; @@ -6650,8 +6632,6 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) static bool S_curse(pTHX_ SV * const sv, const bool check_refcnt) { - dVAR; - PERL_ARGS_ASSERT_CURSE; assert(SvOBJECT(sv)); @@ -6911,7 +6891,6 @@ Perl_sv_len_utf8(pTHX_ SV *const sv) STRLEN Perl_sv_len_utf8_nomg(pTHX_ SV * const sv) { - dVAR; STRLEN len; const U8 *s = (U8*)SvPV_nomg_const(sv, len); @@ -7586,7 +7565,6 @@ if necessary. If the flags include SV_GMAGIC, it handles get-magic, too. I32 Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) { - dVAR; const char *pv1; STRLEN cur1; const char *pv2; @@ -7688,7 +7666,6 @@ I32 Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, const U32 flags) { - dVAR; STRLEN cur1, cur2; const char *pv1, *pv2; I32 cmp; @@ -7784,7 +7761,6 @@ I32 Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, const U32 flags) { - dVAR; #ifdef USE_LOCALE_COLLATE char *pv1, *pv2; @@ -7857,7 +7833,6 @@ settings. char * Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags) { - dVAR; MAGIC *mg; PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS; @@ -8048,7 +8023,6 @@ in the SV (typically, C is a suitable choice). char * Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) { - dVAR; const char *rsptr; STRLEN rslen; STDCHAR rslast; @@ -8518,7 +8492,6 @@ if necessary. Handles operator overloading. Skips handling 'get' magic. void Perl_sv_inc_nomg(pTHX_ SV *const sv) { - dVAR; char *d; int flags; @@ -8591,11 +8564,11 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) while (isALPHA(*d)) d++; while (isDIGIT(*d)) d++; if (d < SvEND(sv)) { + const int numtype = grok_number_flags(SvPVX_const(sv), SvCUR(sv), NULL, PERL_SCAN_TRAILING); #ifdef PERL_PRESERVE_IVUV /* Got to punt this as an integer if needs be, but we don't issue warnings. Probably ought to make the sv_iv_please() that does the conversion if possible, and silently. */ - const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); if (numtype && !(numtype & IS_NUMBER_INFINITY)) { /* Need to try really hard to see if it's an integer. 9.22337203685478e+18 is an integer. @@ -8626,6 +8599,8 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) #endif } #endif /* PERL_PRESERVE_IVUV */ + if (!numtype && ckWARN(WARN_NUMERIC)) + not_incrementable(sv); sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0); return; } @@ -8680,7 +8655,6 @@ if necessary. Handles 'get' magic and operator overloading. void Perl_sv_dec(pTHX_ SV *const sv) { - dVAR; if (!sv) return; SvGETMAGIC(sv); @@ -8699,7 +8673,6 @@ if necessary. Handles operator overloading. Skips handling 'get' magic. void Perl_sv_dec_nomg(pTHX_ SV *const sv) { - dVAR; int flags; if (!sv) @@ -8836,7 +8809,6 @@ statement boundaries. See also C and C. SV * Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags) { - dVAR; SV *sv; if (flags & SV_GMAGIC) @@ -8862,7 +8834,6 @@ See also C and C. SV * Perl_sv_newmortal(pTHX) { - dVAR; SV *sv; new_SV(sv); @@ -8896,7 +8867,6 @@ C is a convenience wrapper for this function, defined as SV * Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags) { - dVAR; SV *sv; /* All the flags we don't support must be zero. @@ -8964,7 +8934,6 @@ For efficiency, consider using C instead. SV * Perl_newSVpv(pTHX_ const char *const s, const STRLEN len) { - dVAR; SV *sv; new_SV(sv); @@ -8988,9 +8957,7 @@ undefined. SV * Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len) { - dVAR; SV *sv; - new_SV(sv); sv_setpvn(sv,buffer,len); return sv; @@ -9009,7 +8976,6 @@ SV if the hek is NULL. SV * Perl_newSVhek(pTHX_ const HEK *const hek) { - dVAR; if (!hek) { SV *sv; @@ -9177,7 +9143,6 @@ Perl_newSVpvf(pTHX_ const char *const pat, ...) SV * Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args) { - dVAR; SV *sv; PERL_ARGS_ASSERT_VNEWSVPVF; @@ -9199,7 +9164,6 @@ The reference count for the SV is set to 1. SV * Perl_newSVnv(pTHX_ const NV n) { - dVAR; SV *sv; new_SV(sv); @@ -9219,7 +9183,6 @@ SV is set to 1. SV * Perl_newSViv(pTHX_ const IV i) { - dVAR; SV *sv; new_SV(sv); @@ -9239,7 +9202,6 @@ The reference count for the SV is set to 1. SV * Perl_newSVuv(pTHX_ const UV u) { - dVAR; SV *sv; new_SV(sv); @@ -9278,7 +9240,6 @@ SV is B incremented. SV * Perl_newRV_noinc(pTHX_ SV *const tmpRef) { - dVAR; SV *sv = newSV_type(SVt_IV); PERL_ARGS_ASSERT_NEWRV_NOINC; @@ -9296,8 +9257,6 @@ Perl_newRV_noinc(pTHX_ SV *const tmpRef) SV * Perl_newRV(pTHX_ SV *const sv) { - dVAR; - PERL_ARGS_ASSERT_NEWRV; return newRV_noinc(SvREFCNT_inc_simple_NN(sv)); @@ -9315,7 +9274,6 @@ Creates a new SV which is an exact duplicate of the original SV. SV * Perl_newSVsv(pTHX_ SV *const old) { - dVAR; SV *sv; if (!old) @@ -9353,7 +9311,6 @@ Perl_sv_reset(pTHX_ const char *s, HV *const stash) void Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash) { - dVAR; char todo[PERL_UCHAR_MAX+1]; const char *send; @@ -9498,7 +9455,6 @@ The flags in C are passed to gv_fetchsv. CV * Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) { - dVAR; GV *gv = NULL; CV *cv = NULL; @@ -9622,8 +9578,6 @@ C and C char * Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) { - dVAR; - PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS; if (flags & SV_GMAGIC) SvGETMAGIC(sv); @@ -9867,7 +9821,6 @@ reference count is 1. The reference count 1 is owned by C. SV* Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) { - dVAR; SV *sv; PERL_ARGS_ASSERT_NEWSVRV; @@ -9935,8 +9888,6 @@ Note that C copies the string while this copies the pointer. SV* Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv) { - dVAR; - PERL_ARGS_ASSERT_SV_SETREF_PV; if (!pv) { @@ -10049,7 +10000,6 @@ of the SV is unaffected. SV* Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) { - dVAR; SV *tmpRef; HV *oldstash = NULL; @@ -10087,7 +10037,6 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) PERL_STATIC_INLINE void S_sv_unglob(pTHX_ SV *const sv, U32 flags) { - dVAR; void *xpvmg; HV *stash; SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal(); @@ -10187,6 +10136,7 @@ void Perl_sv_untaint(pTHX_ SV *const sv) { PERL_ARGS_ASSERT_SV_UNTAINT; + PERL_UNUSED_CONTEXT; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); @@ -10207,6 +10157,7 @@ bool Perl_sv_tainted(pTHX_ SV *const sv) { PERL_ARGS_ASSERT_SV_TAINTED; + PERL_UNUSED_CONTEXT; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); @@ -10522,7 +10473,6 @@ Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, * Warn of missing argument to sprintf, and then return a defined value * to avoid inappropriate "use of uninit" warnings [perl #71000]. */ -#define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */ STATIC SV* S_vcatpvfn_missing_argument(pTHX) { if (ckWARN(WARN_MISSING)) { @@ -10536,7 +10486,6 @@ S_vcatpvfn_missing_argument(pTHX) { STATIC I32 S_expect_number(pTHX_ char **const pattern) { - dVAR; I32 var = 0; PERL_ARGS_ASSERT_EXPECT_NUMBER; @@ -10623,7 +10572,6 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted, const U32 flags) { - dVAR; char *p; char *q; const char *patend; @@ -10640,6 +10588,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p char ebuf[IV_DIG * 4 + NV_DIG + 32]; /* large enough for "%#.#f" --chip */ /* what about long double NVs? --jhi */ + bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */ DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED; @@ -10653,9 +10602,17 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p (void)SvPV_force_nomg(sv, origlen); /* special-case "", "%s", and "%-p" (SVf - see below) */ - if (patlen == 0) + if (patlen == 0) { + if (svmax && ckWARN(WARN_REDUNDANT)) + Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", + PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); return; + } if (patlen == 2 && pat[0] == '%' && pat[1] == 's') { + if (svmax > 1 && ckWARN(WARN_REDUNDANT)) + Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", + PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); + if (args) { const char * const s = va_arg(*args, char*); sv_catpv_nomg(sv, s ? s : nullstr); @@ -10671,6 +10628,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } if (args && patlen == 3 && pat[0] == '%' && pat[1] == '-' && pat[2] == 'p') { + if (svmax > 1 && ckWARN(WARN_REDUNDANT)) + Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", + PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); argsv = MUTABLE_SV(va_arg(*args, void*)); sv_catsv_nomg(sv, argsv); return; @@ -10686,6 +10646,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p pp = pat + 2; while (*pp >= '0' && *pp <= '9') digits = 10 * digits + (*pp++ - '0'); + + /* XXX: Why do this `svix < svmax` test? Couldn't we just + format the first argument and WARN_REDUNDANT if svmax > 1? + Munged by Nicholas Clark in v5.13.0-209-g95ea86d */ if (pp - pat == (int)patlen - 1 && svix < svmax) { const NV nv = SvNV(*svargs); if (*pp == 'g') { @@ -10866,6 +10830,11 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (*q == '$') { ++q; efix = width; + if (!no_redundant_warning) + /* I've forgotten if it's a better + micro-optimization to always set this or to + only set it if it's unset */ + no_redundant_warning = TRUE; } else { goto gotwidth; } @@ -11790,6 +11759,15 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p goto vector; } } + + /* Now that we've consumed all our printf format arguments (svix) + * do we have things left on the stack that we didn't use? + */ + if (!no_redundant_warning && svmax >= svix + 1 && ckWARN(WARN_REDUNDANT)) { + Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", + PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); + } + SvTAINT(sv); RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to save/restore @@ -14278,8 +14256,6 @@ The PV of the sv is returned. char * Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) { - dVAR; - PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8; if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { @@ -14357,7 +14333,6 @@ bool Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, SV *ssv, int *offset, char *tstr, int tlen) { - dVAR; bool ret = FALSE; PERL_ARGS_ASSERT_SV_CAT_DECODE; @@ -14443,8 +14418,6 @@ S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val) STATIC I32 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val) { - dVAR; - PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT; if (!av || SvMAGICAL(av) || !AvARRAY(av) || @@ -14792,9 +14765,9 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, if ( o->op_type == OP_PUSHMARK || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK) ) - o = o->op_sibling; + o = OP_SIBLING(o); - if (!o->op_sibling) { + if (!OP_HAS_SIBLING(o)) { /* one-arg version of open is highly magical */ if (o->op_type == OP_GV) { /* open FOO; */ @@ -14839,7 +14812,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, && ( o->op_type == OP_PUSHMARK || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK))) - o = o->op_sibling->op_sibling; + o = OP_SIBLING(OP_SIBLING(o)); goto do_op2; @@ -14970,7 +14943,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, * it replaced are still in the tree, so we work on them instead. */ o2 = NULL; - for (kid=o; kid; kid = kid->op_sibling) { + for (kid=o; kid; kid = OP_SIBLING(kid)) { const OPCODE type = kid->op_type; if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) @@ -14993,7 +14966,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, sv = find_uninit_var(o, uninit_sv, 1); if (sv) return sv; - o = o->op_sibling; + o = OP_SIBLING(o); } break; } @@ -15012,7 +14985,6 @@ Print appropriate "Use of uninitialized variable" warning. void Perl_report_uninit(pTHX_ const SV *uninit_sv) { - dVAR; if (PL_op) { SV* varname = NULL; if (uninit_sv && PL_curpad) { diff --git a/t/io/utf8.t b/t/io/utf8.t index acce07e..4f96dcc 100644 --- a/t/io/utf8.t +++ b/t/io/utf8.t @@ -223,7 +223,7 @@ is($failed, undef); print F chr(0x100); close(F); - like( $@, 'Wide character in print' ); + like( $@, qr/Wide character in print/ ); undef $@; open F, ">:utf8", $a_file; @@ -257,7 +257,7 @@ is($failed, undef); print F chr(0x100); close(F); - like( $@, 'Wide character in print' ); + like( $@, qr/Wide character in print/ ); } { diff --git a/t/lib/Cname.pm b/t/lib/Cname.pm index 562f59a..4a1bc16 100644 --- a/t/lib/Cname.pm +++ b/t/lib/Cname.pm @@ -28,6 +28,8 @@ sub translator { $str = "\xDF\xDFabc"; utf8::upgrade($str); + no warnings 'deprecated'; + # Create a malformed in first and second characters. $str =~ s/^\C/A/; $str =~ s/^(\C\C)\C/$1A/; diff --git a/t/lib/overload_nomethod.t b/t/lib/overload_nomethod.t index d72dcee..edff163 100644 --- a/t/lib/overload_nomethod.t +++ b/t/lib/overload_nomethod.t @@ -12,11 +12,11 @@ package main; my $foo = Foo->new; eval {my $val = $foo + 1}; -ok( $@ =~ /unimplemented/ ); +ok( $@ =~ /unimplemented/, "'+' not implemented; 'nomethod' special key invoked" ); eval {$foo += 1}; -ok( $@ =~ /unimplemented/ ); +ok( $@ =~ /unimplemented/, "'+=' not implemented; 'nomethod' special key invoked" ); eval {my $val = 0; $val += $foo}; -ok( $@ =~ /unimplemented/ ); +ok( $@ =~ /unimplemented/, "'+=' not implemented; 'nomethod' special key invoked" ); diff --git a/t/lib/warnings/sv b/t/lib/warnings/sv index 41a4fab..f09a97c 100644 --- a/t/lib/warnings/sv +++ b/t/lib/warnings/sv @@ -397,3 +397,21 @@ sprintf "%vd", new version v1.1_0; EXPECT vector argument not supported with alpha versions at - line 2. vector argument not supported with alpha versions at - line 4. +######## +# sv.c +my $x = "a_c"; +++$x; +use warnings "numeric"; +$x = "a_c"; ++$x; +$x = ${ qr/abc/ }; ++$x; +$x = "123x"; ++$x; +$x = "123e"; ++$x; +$x = 0; ++$x; # none of these should warn +$x = "ABC"; ++$x; +$x = "ABC123"; ++$x; +$x = " +10"; ++$x; +EXPECT +Argument "a_c" treated as 0 in increment (++) at - line 5. +Argument "(?^:abc)" treated as 0 in increment (++) at - line 6. +Argument "123x" isn't numeric in preincrement (++) at - line 7. +Argument "123e" isn't numeric in preincrement (++) at - line 8. diff --git a/t/loc_tools.pl b/t/loc_tools.pl index bac8cc7..fccbeeb 100644 --- a/t/loc_tools.pl +++ b/t/loc_tools.pl @@ -16,7 +16,7 @@ sub _trylocale { # Adds the locale given by the first parameter to the list my $locale = shift; my $categories = shift; my $list = shift; - return if grep { $locale eq $_ } @$list; + return if ! $locale || grep { $locale eq $_ } @$list; $categories = [ $categories ] unless ref $categories; diff --git a/t/op/attrproto.t b/t/op/attrproto.t index 13ce107..8e69e33 100644 --- a/t/op/attrproto.t +++ b/t/op/attrproto.t @@ -21,11 +21,11 @@ $SIG{__WARN__} = sub { push @warnings, shift;}; $ret = eval 'package Q; sub A(bar) : prototype(bad) : dummy1 {} prototype \&A;'; is $ret, "bad", "Prototype is set to \"bad\""; is $attrs, "dummy1", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; -like shift @warnings, "Illegal character in prototype for Q::A : bar", +like shift @warnings, qr/Illegal character in prototype for Q::A : bar/, "First warning is bad prototype - bar"; -like shift @warnings, "Illegal character in prototype for Q::A : bad", +like shift @warnings, qr/Illegal character in prototype for Q::A : bad/, "Second warning is bad prototype - bad"; -like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::A', +like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::A/, "Third warning is Prototype overridden"; is @warnings, 0, "No more warnings"; @@ -35,7 +35,7 @@ is @warnings, 0, "No more warnings"; $ret = eval 'package Q; sub B(bar) : prototype(bad) dummy2 {4} prototype \&B;'; is $ret, "bad", "Prototype is set to \"bad\""; is $attrs, "dummy2", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; - like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::B', + like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::B/, "First warning is Prototype overridden"; is @warnings, 0, "No more warnings"; } @@ -44,13 +44,13 @@ is @warnings, 0, "No more warnings"; $ret = eval 'package Q; sub B(ignored) : prototype(baz) : dummy3; prototype \&B;'; is $ret, "bad", "Declaring with prototype(..) after definition doesn't change the prototype"; is $attrs, "dummy3", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; -like shift @warnings, "Illegal character in prototype for Q::B : ignored", +like shift @warnings, qr/Illegal character in prototype for Q::B : ignored/, "Shifting off warning for the 'ignored' prototype"; -like shift @warnings, "Illegal character in prototype for Q::B : baz", +like shift @warnings, qr/Illegal character in prototype for Q::B : baz/, "Attempting to redeclare triggers Illegal character warning"; -like shift @warnings, 'Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B', +like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B/, "Shifting off Prototype overridden warning"; -like shift @warnings, 'Prototype mismatch: sub Q::B \(bad\) vs \(baz\)', +like shift @warnings, qr/Prototype mismatch: sub Q::B \(bad\) vs \(baz\)/, "Attempting to redeclare triggers prototype mismatch warning against first prototype"; is @warnings, 0, "No more warnings"; @@ -59,22 +59,22 @@ $ret = eval 'package Q; sub B(ignored) : prototype(baz) dummy4 {5}; prototype \& is $ret, "baz", "Redefining with prototype(..) changes the prototype"; is $attrs, "dummy4", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)"; is &Q::B, 5, "Function successfully redefined"; -like shift @warnings, "Illegal character in prototype for Q::B : ignored", +like shift @warnings, qr/Illegal character in prototype for Q::B : ignored/, "Attempting to redeclare triggers Illegal character warning"; -like shift @warnings, "Illegal character in prototype for Q::B : baz", +like shift @warnings, qr/Illegal character in prototype for Q::B : baz/, "Attempting to redeclare triggers Illegal character warning"; -like shift @warnings, 'Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B', +like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B/, "Shifting off Prototype overridden warning"; -like shift @warnings, 'Prototype mismatch: sub Q::B \(bad\) vs \(baz\)', +like shift @warnings, qr/Prototype mismatch: sub Q::B \(bad\) vs \(baz\)/, "Attempting to redeclare triggers prototype mismatch warning"; -like shift @warnings, 'Subroutine B redefined', +like shift @warnings, qr/Subroutine B redefined/, "Only other warning is subroutine redefinition"; is @warnings, 0, "No more warnings"; # Multiple prototype declarations only takes the last one $ret = eval 'package Q; sub dummy6 : prototype($$) : prototype($$$) {}; prototype \&dummy6;'; is $ret, "\$\$\$", "Last prototype declared wins"; -like shift @warnings, 'Attribute prototype\(\$\$\$\) discards earlier prototype attribute in same sub', +like shift @warnings, qr/Attribute prototype\(\$\$\$\) discards earlier prototype attribute in same sub/, "Multiple prototype declarations warns"; is @warnings, 0, "No more warnings"; @@ -82,20 +82,20 @@ is @warnings, 0, "No more warnings"; eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(new)";'; $ret = prototype \&Q::B; is $ret, "new", "use attributes also sets the prototype"; -like shift @warnings, 'Prototype mismatch: sub Q::B \(baz\) vs \(new\)', +like shift @warnings, qr/Prototype mismatch: sub Q::B \(baz\) vs \(new\)/, "Prototype mismatch warning triggered"; is @warnings, 0, "No more warnings"; eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(\$\$~";'; $ret = prototype \&Q::B; is $ret, "new", "A malformed prototype doesn't reset it"; -like $@, "Unterminated attribute parameter in attribute list", "Malformed prototype croaked"; +like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked"; is @warnings, 0, "Malformed prototype isn't just a warning"; eval 'use attributes __PACKAGE__, \&foo, "prototype($$\x{100}";'; $ret = prototype \&Q::B; is $ret, "new", "A malformed prototype doesn't reset it"; -like $@, "Unterminated attribute parameter in attribute list", "Malformed prototype croaked"; +like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked"; is @warnings, 0, "Malformed prototype isn't just a warning"; # Anonymous subs (really just making sure they don't crash, since the prototypes @@ -108,11 +108,11 @@ is @warnings, 0, "Malformed prototype isn't just a warning"; # the name to '?' before calling the proto check, despite setting # it to the real name very shortly after. # In short - if this test breaks, just change the test. - like shift @warnings, 'Illegal character in prototype for \? : bar', + like shift @warnings, qr/Illegal character in prototype for \? : bar/, "(anon) bar triggers illegal proto warnings"; - like shift @warnings, "Illegal character in prototype for Q::__ANON__ : baz", + like shift @warnings, qr/Illegal character in prototype for Q::__ANON__ : baz/, "(anon) baz triggers illegal proto warnings"; - like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in Q::__ANON__', + like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in Q::__ANON__/, "(anon) overridden warning triggered in anonymous sub"; is @warnings, 0, "No more warnings"; } @@ -123,11 +123,11 @@ is @warnings, 0, "Malformed prototype isn't just a warning"; no warnings "experimental::lexical_subs"; $ret = eval 'my sub foo(bar) : prototype(baz) {}; prototype \&foo;'; is $ret, "baz", "my sub foo honors the prototype attribute"; - like shift @warnings, 'Illegal character in prototype for foo : bar', + like shift @warnings, qr/Illegal character in prototype for foo : bar/, "(lexical) bar triggers illegal proto warnings"; - like shift @warnings, "Illegal character in prototype for foo : baz", + like shift @warnings, qr/Illegal character in prototype for foo : baz/, "(lexical) baz triggers illegal proto warnings"; - like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in foo', + like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in foo/, "(lexical) overridden warning triggered in anonymous sub"; is @warnings, 0, "No more warnings"; } diff --git a/t/op/attrs.t b/t/op/attrs.t index ec6768e..5e97691 100644 --- a/t/op/attrs.t +++ b/t/op/attrs.t @@ -84,10 +84,10 @@ eval 'my A $x : plugh;'; is $@, ''; eval 'package Cat; my Cat @socks;'; -like $@, ''; +is $@, ''; eval 'my Cat %nap;'; -like $@, ''; +is $@, ''; sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } sub X::foo { 1 } diff --git a/t/op/bop.t b/t/op/bop.t index fa08e98..f946d8b 100644 --- a/t/op/bop.t +++ b/t/op/bop.t @@ -353,7 +353,7 @@ is($a, "\xFF", "~ works with utf-8"); # This would cause a segfault without malloc wrap SKIP: { skip "No malloc wrap checks" unless $Config::Config{usemallocwrap}; - like( runperl(prog => 'eval q($#a>>=1); print 1'), "^1\n?" ); + like( runperl(prog => 'eval q($#a>>=1); print 1'), qr/^1\n?/ ); } # [perl #37616] Bug in &= (string) and/or m// @@ -448,7 +448,11 @@ SKIP: { # U+0800 is three bytes in UTF-8/UTF-EBCDIC. no warnings "utf8"; - { use bytes; $str =~ s/\C\C\z//; } + { + use bytes; + no warnings 'deprecated'; + $str =~ s/\C\C\z//; + } # it's really bogus that (~~malformed) is \0. my $ref = "\x{10000}\0"; @@ -458,7 +462,11 @@ SKIP: { # exercises a different branch in pp_subsr() $str = "\x{10000}\x{800}"; - { use bytes; $str =~ s/\C\C\z/\0\0\0/; } + { + use bytes; + no warnings 'deprecated'; + $str =~ s/\C\C\z/\0\0\0/; + } # it's also bogus that (~~malformed) is \0\0\0\0. my $ref = "\x{10000}\0\0\0\0"; diff --git a/t/op/coreamp.t b/t/op/coreamp.t index addc4bb..aef3260 100644 --- a/t/op/coreamp.t +++ b/t/op/coreamp.t @@ -882,13 +882,13 @@ $tests += 3; test_proto 'time'; $tests += 2; -like &mytime, '^\d+\z', '&time in scalar context'; -like join('-', &mytime), '^\d+\z', '&time in list context'; +like &mytime, qr/^\d+\z/, '&time in scalar context'; +like join('-', &mytime), qr/^\d+\z/, '&time in list context'; test_proto 'times'; $tests += 2; -like &mytimes, '^[\d.]+\z', '× in scalar context'; -like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z', +like &mytimes, qr/^[\d.]+\z/, '× in scalar context'; +like join('-',&mytimes), qr/^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z/, '× in list context'; test_proto 'uc', 'aa', 'AA'; diff --git a/t/op/die.t b/t/op/die.t index 8faef6a..c98b8ff 100644 --- a/t/op/die.t +++ b/t/op/die.t @@ -15,8 +15,8 @@ eval { die if $@; }; -like($@, '^Horribly', 'die with no args propagates $@'); -like($@, 'propagated', '... and appends a phrase'); +like($@, qr/^Horribly/, 'die with no args propagates $@'); +like($@, qr/\.{3}propagated at/, '... and appends a phrase'); { local $SIG{__DIE__} = sub { is( $_[0], "[\000]\n", 'Embedded null passed to signal handler' )}; diff --git a/t/op/each.t b/t/op/each.t index 4cfc03a..3fc9451 100644 --- a/t/op/each.t +++ b/t/op/each.t @@ -196,7 +196,7 @@ for my $k (qw(each keys values)) { isnt($v1,$v2,"if(%foo) didnt mess with each (value)"); is($rest,3,"Got the expect number of keys"); my $hsv=1 && %foo; - like($hsv,'/',"Got bucket stats from %foo in scalar assignment context"); + like($hsv,qr[/],"Got bucket stats from %foo in scalar assignment context"); my @arr=%foo&&%foo; is(@arr,10,"Got expected number of elements in list context"); } @@ -215,7 +215,7 @@ for my $k (qw(each keys values)) { isnt($v1,$v2,"if(%foo) didnt mess with each (value)"); is($rest,3,"Got the expect number of keys"); my $hsv=1 && %foo; - like($hsv,'/',"Got bucket stats from %foo in scalar assignment context"); + like($hsv,qr[/],"Got bucket stats from %foo in scalar assignment context"); my @arr=%foo&&%foo; is(@arr,10,"Got expected number of elements in list context"); } diff --git a/t/op/eval.t b/t/op/eval.t index e4c2f70..f404df5 100644 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan(tests => 130); +plan(tests => 132); eval 'pass();'; @@ -517,6 +517,16 @@ END_EVAL_TEST is(Internals::SvREFCNT(%$t), $count_expected, 'RT 63110'); } +# make sure default arg eval only adds a hints hash once to entereval +# +{ + local $_ = "21+12"; + is(eval, 33, 'argless eval without hints'); + use feature qw(:5.10); + local $_ = "42+24"; + is(eval, 66, 'argless eval with hints'); +} + { # test that the CV compiled for the eval is freed by checking that no additional # reference to outside lexicals are made. diff --git a/t/op/inc.t b/t/op/inc.t index 8db0660..5135ab7 100644 --- a/t/op/inc.t +++ b/t/op/inc.t @@ -274,9 +274,12 @@ isnt(scalar eval { my $pvbm = PVBM; --$pvbm }, undef, "predecrement defined"); $_ = ${qr //}; $_--; is($_, -1, 'regexp--'); -$_ = ${qr //}; -$_++; -is($_, 1, 'regexp++'); +{ + no warnings 'numeric'; + $_ = ${qr //}; + $_++; + is($_, 1, 'regexp++'); +} $_ = v97; $_++; diff --git a/t/op/local.t b/t/op/local.t index 03a8310..7ff21ab 100644 --- a/t/op/local.t +++ b/t/op/local.t @@ -779,7 +779,7 @@ is($@, ""); like( runperl(stderr => 1, prog => 'use constant foo => q(a);' . 'index(q(a), foo);' . - 'local *g=${::}{foo};print q(ok);'), "ok", "[perl #52740]"); + 'local *g=${::}{foo};print q(ok);'), qr/^ok$/, "[perl #52740]"); # related to perl #112966 # Magic should not cause elements not to be deleted after scope unwinding diff --git a/t/op/magic.t b/t/op/magic.t index da3420c..015d41b 100644 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -429,8 +429,9 @@ EOP chomp(my $argv0 = $maybe_ps->("ps h $$")); chomp(my $prctl = $maybe_ps->("ps hc $$")); - like($argv0, $name, "Set process name through argv[0] ($argv0)"); - like($prctl, substr($name, 0, 15), "Set process name through prctl() ($prctl)"); + like($argv0, qr/$name/, "Set process name through argv[0] ($argv0)"); + my $name_substr = substr($name, 0, 15); + like($prctl, qr/$name_substr/, "Set process name through prctl() ($prctl)"); } } diff --git a/t/op/method.t b/t/op/method.t index 0f53c3a..648f003 100644 --- a/t/op/method.t +++ b/t/op/method.t @@ -404,7 +404,7 @@ is $kalled, 1, 'calling a class method via a magic variable'; *NulTest::AUTOLOAD = sub { our $AUTOLOAD; return $AUTOLOAD }; - like(NulTest->${ \"nul\0test" }, "nul\0test", "AUTOLOAD is nul-clean"); + like(NulTest->${ \"nul\0test" }, qr/nul\0test/, "AUTOLOAD is nul-clean"); } diff --git a/t/op/pack.t b/t/op/pack.t index 99cb533..357f15b 100644 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -1275,7 +1275,7 @@ SKIP: { # comma warning only once @warning = (); $x = pack( 'C(C,C)C,C', 65..71 ); - like( scalar @warning, 1 ); + cmp_ok( scalar(@warning), '==', 1 ); # forbidden code in [] eval { my $x = pack( 'A[@4]', 'XXXX' ); }; diff --git a/t/op/qr.t b/t/op/qr.t index ac017eb..dc49f1e 100644 --- a/t/op/qr.t +++ b/t/op/qr.t @@ -89,12 +89,12 @@ is ref \$t2, 'main', 'regexp assignment is not maledictory'; $_ = 1.1; $_ = ${qr//}; is 0+$_, 0, 'double upgraded to regexp'; - like $w, 'numeric', 'produces non-numeric warning'; + like $w, qr/numeric/, 'produces non-numeric warning'; undef $w; $_ = 1; $_ = ${qr//}; is 0+$_, 0, 'int upgraded to regexp'; - like $w, 'numeric', 'likewise produces non-numeric warning'; + like $w, qr/numeric/, 'likewise produces non-numeric warning'; } sub { diff --git a/t/op/readline.t b/t/op/readline.t index 1cfd78c..99ff63c 100644 --- a/t/op/readline.t +++ b/t/op/readline.t @@ -12,7 +12,7 @@ plan tests => 30; # TARG. Test that we respect SvREADONLY. use constant roref => \2; eval { for (roref) { $_ = } }; -like($@, 'Modification of a read-only value attempted', '[perl #19566]'); +like($@, qr/Modification of a read-only value attempted/, '[perl #19566]'); # [perl #21628] { diff --git a/t/op/ref.t b/t/op/ref.t index a6564ce..244dbd8 100644 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -617,7 +617,7 @@ is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' ); { local $@; eval { ()[0]{foo} }; - like ( "$@", "Can't use an undefined value as a HASH reference", + like ( "$@", qr/Can't use an undefined value as a HASH reference/, "deref of undef from list slice fails" ); } diff --git a/t/op/sprintf.t b/t/op/sprintf.t index 17e269a..4c41b16 100644 --- a/t/op/sprintf.t +++ b/t/op/sprintf.t @@ -65,6 +65,8 @@ $SIG{__WARN__} = sub { $w .= ' UNINIT'; } elsif ($_[0] =~ /^Missing argument/) { $w .= ' MISSING'; + } elsif ($_[0] =~ /^Redundant argument/) { + $w .= ' REDUNDANT'; } elsif ($_[0]=~/^vector argument not supported with alpha versions/) { $w .= ' ALPHA'; } else { @@ -174,14 +176,14 @@ for (@tests) { # template data result __END__ ->%6. 6s< >''< >%6. 6s INVALID< >(See use of $w in code above)< ->%6 .6s< >''< >%6 .6s INVALID< ->%6.6 s< >''< >%6.6 s INVALID< ->%A< >''< >%A INVALID< +>%6. 6s< >''< >%6. 6s INVALID REDUNDANT< >(See use of $w in code above)< +>%6 .6s< >''< >%6 .6s INVALID REDUNDANT< +>%6.6 s< >''< >%6.6 s INVALID REDUNDANT< +>%A< >''< >%A INVALID REDUNDANT< >%B< >2**32-1< >11111111111111111111111111111111< >%+B< >2**32-1< >11111111111111111111111111111111< >%#B< >2**32-1< >0B11111111111111111111111111111111< ->%C< >''< >%C INVALID< +>%C< >''< >%C INVALID REDUNDANT< >%D< >0x7fffffff< >2147483647< >Synonym for %ld< >%E< >123456.789< >1.234568E+05< >Like %e, but using upper-case "E"< >%F< >123456.789< >123456.789000< >Synonym for %f< @@ -191,27 +193,27 @@ __END__ >%G< >12345.6789< >12345.7< >%G< >1234567e96< >1.23457E+102< >exponent too big skip: os390< >%G< >.1234567e-101< >1.23457E-102< >exponent too small skip: os390< ->%H< >''< >%H INVALID< ->%I< >''< >%I INVALID< ->%J< >''< >%J INVALID< ->%K< >''< >%K INVALID< ->%L< >''< >%L INVALID< ->%M< >''< >%M INVALID< ->%N< >''< >%N INVALID< +>%H< >''< >%H INVALID REDUNDANT< +>%I< >''< >%I INVALID REDUNDANT< +>%J< >''< >%J INVALID REDUNDANT< +>%K< >''< >%K INVALID REDUNDANT< +>%L< >''< >%L INVALID REDUNDANT< +>%M< >''< >%M INVALID REDUNDANT< +>%N< >''< >%N INVALID REDUNDANT< >%O< >2**32-1< >37777777777< >Synonym for %lo< ->%P< >''< >%P INVALID< ->%Q< >''< >%Q INVALID< ->%R< >''< >%R INVALID< ->%S< >''< >%S INVALID< ->%T< >''< >%T INVALID< +>%P< >''< >%P INVALID REDUNDANT< +>%Q< >''< >%Q INVALID REDUNDANT< +>%R< >''< >%R INVALID REDUNDANT< +>%S< >''< >%S INVALID REDUNDANT< +>%T< >''< >%T INVALID REDUNDANT< >%U< >2**32-1< >4294967295< >Synonym for %lu< ->%V< >''< >%V INVALID< ->%W< >''< >%W INVALID< +>%V< >''< >%V INVALID REDUNDANT< +>%W< >''< >%W INVALID REDUNDANT< >%X< >2**32-1< >FFFFFFFF< >Like %x, but with u/c letters< >%#X< >2**32-1< >0XFFFFFFFF< ->%Y< >''< >%Y INVALID< ->%Z< >''< >%Z INVALID< ->%a< >''< >%a INVALID< +>%Y< >''< >%Y INVALID REDUNDANT< +>%Z< >''< >%Z INVALID REDUNDANT< +>%a< >''< >%a INVALID REDUNDANT< >%b< >2**32-1< >11111111111111111111111111111111< >%+b< >2**32-1< >11111111111111111111111111111111< >%#b< >2**32-1< >0b11111111111111111111111111111111< @@ -396,7 +398,7 @@ __END__ >%.0f< >1< >1< >%#.0f< >1< >1.< >%.0lf< >1< >1< >'l' should have no effect< ->%.0hf< >1< >%.0hf INVALID< >'h' should be rejected< +>%.0hf< >1< >%.0hf INVALID REDUNDANT< >'h' should be rejected< >%g< >12345.6789< >12345.7< >%+g< >12345.6789< >+12345.7< >%#g< >12345.6789< >12345.7< @@ -434,12 +436,12 @@ __END__ >%-13g< >1234567.89< >1.23457e+06 < >%g< >.1234567E-101< >1.23457e-102< >exponent too small skip: os390< >%g< >1234567E96< >1.23457e+102< >exponent too big skip: os390< ->%h< >''< >%h INVALID< +>%h< >''< >%h INVALID REDUNDANT< >%i< >123456.789< >123456< >Synonym for %d< ->%j< >''< >%j INVALID< ->%k< >''< >%k INVALID< ->%l< >''< >%l INVALID< ->%m< >''< >%m INVALID< +>%j< >''< >%j INVALID REDUNDANT< +>%k< >''< >%k INVALID REDUNDANT< +>%l< >''< >%l INVALID REDUNDANT< +>%m< >''< >%m INVALID REDUNDANT< >%s< >sprintf('%%n%n %d', $n, $n)< >%n 2< >Slight sneakiness to test %n< >%s< >$n="abc"; sprintf(' %n%s', substr($n,1,1), $n)< > a1c< >%n w/magic< >%s< >no warnings; sprintf('%s%n', chr(256)x5, $n),$n< >5< >Unicode %n< @@ -510,9 +512,9 @@ __END__ >%#06.4o< >18< > 0022< >0 flag with precision: no effect< >%d< >$p=sprintf('%p',$p);$p=~/^[0-9a-f]+$/< >1< >Coarse hack: hex from %p?< >%d< >$p=sprintf('%-8p',$p);$p=~/^[0-9a-f]+\s*$/< >1< >Coarse hack: hex from %p?< ->%#p< >''< >%#p INVALID< ->%q< >''< >%q INVALID< ->%r< >''< >%r INVALID< +>%#p< >''< >%#p INVALID REDUNDANT< +>%q< >''< >%q INVALID REDUNDANT< +>%r< >''< >%r INVALID REDUNDANT< >%s< >[]< > MISSING< > %s< >[]< > MISSING< >%s< >'string'< >string< @@ -534,7 +536,7 @@ __END__ >%3.*s< >[1, 'string']< > s< >%3.*s< >[0, 'string']< > < >%3.*s< >[-1,'string']< >string< >negative precision to be ignored< ->%t< >''< >%t INVALID< +>%t< >''< >%t INVALID REDUNDANT< >%u< >2**32-1< >4294967295< >%+u< >2**32-1< >4294967295< >%#u< >2**32-1< >4294967295< @@ -549,8 +551,8 @@ __END__ >% 4.3u< >18< > 018< >%04.3u< >18< > 018< >0 flag with precision: no effect< >%.3u< >18< >018< ->%v< >''< >%v INVALID< ->%w< >''< >%w INVALID< +>%v< >''< >%v INVALID REDUNDANT< +>%w< >''< >%w INVALID REDUNDANT< >%x< >2**32-1< >ffffffff< >%+x< >2**32-1< >ffffffff< >%#x< >2**32-1< >0xffffffff< @@ -632,37 +634,37 @@ __END__ >%#+.*x< >[-1,0]< >0< >%# .*x< >[-1,0]< >0< >%#0.*x< >[-1,0]< >0< ->%y< >''< >%y INVALID< ->%z< >''< >%z INVALID< +>%y< >''< >%y INVALID REDUNDANT< +>%z< >''< >%z INVALID REDUNDANT< >%2$d %1$d< >[12, 34]< >34 12< ->%*2$d< >[12, 3]< > 12< +>%*2$d< >[12, 3]< > 12 REDUNDANT< >%2$d %d< >[12, 34]< >34 12< >%2$d %d %d< >[12, 34]< >34 12 34< >%3$d %d %d< >[12, 34, 56]< >56 12 34< >%2$*3$d %d< >[12, 34, 3]< > 34 12< ->%*3$2$d %d< >[12, 34, 3]< >%*3$2$d 12 INVALID< +>%*3$2$d %d< >[12, 34, 3]< >%*3$2$d 12 INVALID REDUNDANT< >%2$d< >12< >0 MISSING< ->%0$d< >12< >%0$d INVALID< +>%0$d< >12< >%0$d INVALID REDUNDANT< >%1$$d< >12< >%1$$d INVALID< >%1$1$d< >12< >%1$1$d INVALID< ->%*2$*2$d< >[12, 3]< >%*2$*2$d INVALID< ->%*2*2$d< >[12, 3]< >%*2*2$d INVALID< ->%*2$1d< >[12, 3]< >%*2$1d INVALID< +>%*2$*2$d< >[12, 3]< >%*2$*2$d INVALID REDUNDANT< +>%*2*2$d< >[12, 3]< >%*2*2$d INVALID REDUNDANT< +>%*2$1d< >[12, 3]< >%*2$1d INVALID REDUNDANT< >%0v2.2d< >''< >< ->%vc,%d< >[63, 64, 65]< >%vc,63 INVALID< ->%v%,%d< >[63, 64, 65]< >%v%,63 INVALID< ->%vd,%d< >["\x1", 2, 3]< >1,2< ->%vf,%d< >[1, 2, 3]< >%vf,1 INVALID< ->%vF,%d< >[1, 2, 3]< >%vF,1 INVALID< ->%ve,%d< >[1, 2, 3]< >%ve,1 INVALID< ->%vE,%d< >[1, 2, 3]< >%vE,1 INVALID< ->%vg,%d< >[1, 2, 3]< >%vg,1 INVALID< ->%vG,%d< >[1, 2, 3]< >%vG,1 INVALID< ->%vp< >''< >%vp INVALID< ->%vn< >''< >%vn INVALID< ->%vs,%d< >[1, 2, 3]< >%vs,1 INVALID< ->%v_< >''< >%v_ INVALID< ->%v#x< >''< >%v#x INVALID< +>%vc,%d< >[63, 64, 65]< >%vc,63 INVALID REDUNDANT< +>%v%,%d< >[63, 64, 65]< >%v%,63 INVALID REDUNDANT< +>%vd,%d< >["\x1", 2, 3]< >1,2 REDUNDANT< +>%vf,%d< >[1, 2, 3]< >%vf,1 INVALID REDUNDANT< +>%vF,%d< >[1, 2, 3]< >%vF,1 INVALID REDUNDANT< +>%ve,%d< >[1, 2, 3]< >%ve,1 INVALID REDUNDANT< +>%vE,%d< >[1, 2, 3]< >%vE,1 INVALID REDUNDANT< +>%vg,%d< >[1, 2, 3]< >%vg,1 INVALID REDUNDANT< +>%vG,%d< >[1, 2, 3]< >%vG,1 INVALID REDUNDANT< +>%vp< >''< >%vp INVALID REDUNDANT< +>%vn< >''< >%vn INVALID REDUNDANT< +>%vs,%d< >[1, 2, 3]< >%vs,1 INVALID REDUNDANT< +>%v_< >''< >%v_ INVALID REDUNDANT< +>%v#x< >''< >%v#x INVALID REDUNDANT< >%v02x< >"\x66\x6f\x6f\012"< >66.6f.6f.0a< >%#v.8b< >"\141\000\142"< >0b01100001.00000000.0b01100010< >perl #39530< >%#v.0o< >"\001\000\002\000"< >01.0.02.0< @@ -700,10 +702,10 @@ __END__ >%#v.2X< >"\141\x{1e01}\017\142\x{1e03}"< >0X61.0X1E01.0X0F.0X62.0X1E03< >perl #39530< >%V-%s< >["Hello"]< >%V-Hello INVALID< >%K %d %d< >[13, 29]< >%K 13 29 INVALID< ->%*.*K %d< >[13, 29, 76]< >%*.*K 13 INVALID< +>%*.*K %d< >[13, 29, 76]< >%*.*K 13 INVALID REDUNDANT< >%4$K %d< >[45, 67]< >%4$K 45 MISSING INVALID< >%d %K %d< >[23, 45]< >23 %K 45 INVALID< ->%*v*999\$d %d %d< >[11, 22, 33]< >%*v*999\$d 11 22 INVALID< +>%*v*999\$d %d %d< >[11, 22, 33]< >%*v*999\$d 11 22 INVALID REDUNDANT< >%#b< >0< >0< >%#o< >0< >0< >%#x< >0< >0< diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t index d914de0..6fd0bde 100644 --- a/t/op/sprintf2.t +++ b/t/op/sprintf2.t @@ -8,7 +8,11 @@ BEGIN { require './test.pl'; } -plan tests => 1370; +# We'll run 12 extra tests (see below) if $Q is false. +eval { my $q = pack "q", 0 }; +my $Q = $@ eq ''; + +plan tests => 1406 + ($Q ? 0 : 12); use strict; use Config; @@ -45,7 +49,7 @@ for my $i (1, 3, 5, 10) { # Used to mangle PL_sv_undef fresh_perl_like( 'print sprintf "xxx%n\n"; print undef', - 'Modification of a read-only value attempted at - line 1\.', + qr/Modification of a read-only value attempted at - line 1\./, { switches => [ '-w' ] }, q(%n should not be able to modify read-only constants), ); @@ -77,6 +81,142 @@ for (int(~0/2+1), ~0, "9999999999999999999") { is($bad, 0, "unexpected warnings"); } +# Tests for "missing argument" and "redundant argument" warnings +{ + my ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0); + local $SIG{__WARN__} = sub { + if ($_[0] =~ /missing argument/i) { + $warn_missing++ + } + elsif ($_[0] =~ /redundant argument/i) { + $warn_redundant++ + } + else { + $warn_bad++ + } + }; + + my @tests = ( + # The "", "%s", and "%-p" formats have special-case handling + # in sv.c + { + fmt => "", + args => [ qw( x ) ], + res => "", + m => 0, + r => 1, + }, + { + fmt => "%s", + args => [ qw( x y ) ], + res => "x", + m => 0, + r => 1, + }, + { + fmt => "%-p", + args => [ qw( x y ) ], + res => qr/^[0-9a-f]+$/as, + m => 0, + r => 1, + }, + # Other non-specialcased patterns + { + fmt => "%s : %s", + args => [ qw( a b c ) ], + res => "a : b", + m => 0, + r => 1, + }, + { + fmt => "%s : %s : %s", + args => [ qw( a b c d e ) ], + res => "a : b : c", + m => 0, + # Note how we'll only warn about redundant arguments once, + # even though both "d" and "e" are redundant... + r => 1, + }, + { + fmt => "%s : %s : %s", + args => [ ], + res => " : : ", + # ...But when arguments are missing we'll warn about every + # missing argument. This difference between the two + # warnings is a feature. + m => 3, + r => 0, + }, + + # Tests for format parameter indexes. + # + # Deciding what to do about these is a bit tricky, and so is + # "correctly" warning about missing arguments on them. + # + # Should we warn if you supply 4 arguments but only use + # argument 1,3 & 4? Or only if you supply 5 arguments and your + # highest used argument is 4? + # + # For some uses of this printf feature (e.g. i18n systems) + # it's a always a logic error to not print out every provided + # argument, but for some other uses skipping some might be a + # feature (although you could argue that then printf should be + # called as e.g: + # + # printf q[%1$s %3$s], x(), undef, z(); + # + # Instead of: + # + # printf q[%1$s %3$s], x(), y(), z(); + # + # Since calling the (possibly expensive) y() function is + # completely redundant there. + # + # We deal with all these potential problems by not even + # trying. If the pattern contains any format parameter indexes + # whatsoever we'll never warn about redundant arguments. + { + fmt => '%1$s : %2$s', + args => [ qw( x y z ) ], + res => "x : y", + m => 0, + r => 0, + }, + { + fmt => '%2$s : %4$s : %5$s', + args => [ qw( a b c d )], + res => "b : d : ", + m => 1, + r => 0, + }, + { + fmt => '%s : %1$s : %s', + args => [ qw( x y z ) ], + res => "x : x : y", + m => 0, + r => 0, + }, + + ); + + for my $i (0..$#tests) { + my $test = $tests[$i]; + my $result = sprintf $test->{fmt}, @{$test->{args}}; + + my $prefix = "For format '$test->{fmt}' and arguments/result '@{$test->{args}}'/'$result'"; + if (ref $test->{res} eq 'Regexp') { + like($result, $test->{res}, "$prefix got the right result"); + } else { + is($result, $test->{res}, "$prefix got the right result"); + } + is($warn_missing, $test->{m}, "$prefix got '$test->{m}' 'missing argument' warnings"); + is($warn_redundant, $test->{r}, "$prefix got '$test->{r}' 'redundant argument' warnings"); + is($warn_bad, 0, "$prefix No unknown warnings"); + + ($warn_missing, $warn_redundant, $warn_bad) = (0,0,0); + } +} + { foreach my $ord (0 .. 255) { my $bad = 0; @@ -146,9 +286,6 @@ foreach my $n (2**1e100, -2**1e100, 2**1e100/2**1e100) { # +Inf, -Inf, NaN } # test %ll formats with and without HAS_QUAD -eval { my $q = pack "q", 0 }; -my $Q = $@ eq ''; - my @tests = ( [ '%lld' => [qw( 4294967296 -100000000000000 )] ], [ '%lli' => [qw( 4294967296 -100000000000000 )] ], @@ -161,9 +298,17 @@ my @tests = ( for my $t (@tests) { my($fmt, $nums) = @$t; for my $num (@$nums) { - my $w; local $SIG{__WARN__} = sub { $w = shift }; - is(sprintf($fmt, $num), $Q ? $num : $fmt, "quad: $fmt -> $num"); - like($w, $Q ? '' : qr/Invalid conversion in sprintf: "$fmt"/, "warning: $fmt"); + my $w = ''; + local $SIG{__WARN__} = sub { $w .= shift }; + my $sprintf_got = sprintf($fmt, $num); + if ($Q) { + is($sprintf_got, $num, "quad: $fmt -> $num"); + is($w, '', "no warnings for: $fmt -> $num"); + } else { + is($sprintf_got, $fmt, "quad unsupported: $fmt -> $fmt"); + like($w, qr/Invalid conversion in sprintf: "$fmt"/, "got warning about invalid conversion from fmt : $fmt"); + like($w, qr/Redundant argument in sprintf/, "got warning about redundant argument in sprintf from fmt : $fmt"); + } } } diff --git a/t/op/utftaint.t b/t/op/utftaint.t index df99c8d..d734927 100644 --- a/t/op/utftaint.t +++ b/t/op/utftaint.t @@ -18,7 +18,7 @@ sub tainted ($) { } require './test.pl'; -plan(tests => 3*10 + 3*8 + 2*16 + 2); +plan(tests => 3*10 + 3*8 + 2*16 + 3); my $arg = $ENV{PATH}; # a tainted value use constant UTF8 => "\x{1234}"; @@ -149,3 +149,12 @@ for my $ary ([ascii => 'perl'], [latin1 => "\xB6"]) { 'ok', {switches => ["-T", "-l"]}, "therefore swash_init should be taint agnostic"); } + +{ + # RT #122148: s///e on tainted utf8 strings got pos() messed up in 5.20 + + my @p; + my $s = "\x{100}\x{100}\x{100}\x{100}". $^X; + $s =~ s/\x{100}/push @p, pos($s); "xxxx";/eg; + is("@p", "0 1 2 3", "RT #122148"); +} diff --git a/t/porting/libperl.t b/t/porting/libperl.t new file mode 100644 index 0000000..8f1dc05 --- /dev/null +++ b/t/porting/libperl.t @@ -0,0 +1,486 @@ +#!/usr/bin/perl -w + +# Try opening libperl.a with nm, and verifying it has the kind of +# symbols we expect, and no symbols we should avoid. +# +# Fail softly, expect things only on known platforms: +# - linux +# - darwin (OS X), both x86 and ppc +# - freebsd +# and on other platforms, and if things seem odd, just give up (skip_all). +# +# Also, if the rarely-used builds options -DPERL_GLOBAL_STRUCT or +# -DPERL_GLOBAL_STRUCT_PRIVATE are used, verify that they did what +# they were meant to do, hide the global variables (see perlguts for +# the details). +# +# Debugging tip: nm output (this script's input) can be faked by +# giving one command line argument for this script: it should be +# either the filename to read, or "-" for STDIN. You can also append +# "@style" (where style is a supported nm style, like "gnu" or "darwin") +# to this filename for "cross-parsing". +# +# Some terminology: +# - "text" symbols are code +# - "data" symbols are data (duh), with subdivisions: +# - "bss": (Block-Started-by-Symbol: originally from IBM assembler...), +# uninitialized data, which often even doesn't exist in the object +# file as such, only its size does, which is then created on demand +# by the loader +# - "const": initialized read-only data, like string literals +# - "common": uninitialized data unless initialized... +# (the full story is too long for here, see "man nm") +# - "data": initialized read-write data +# (somewhat confusingly below: "data data", but it makes code simpler) +# - "undefined": external symbol referred to by an object, +# most likely a text symbol. Can be either a symbol defined by +# a Perl object file but referred to by other Perl object files, +# or a completely external symbol from libc, or other system libraries. + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require "./test.pl"; +} + +use strict; + +use Config; + +if ($Config{cc} =~ /g\+\+/) { + # XXX Could use c++filt, maybe. + skip_all "on g++"; +} + +my $libperl_a; + +for my $f (qw(../libperl.a libperl.a)) { + if (-f $f) { + $libperl_a = $f; + last; + } +} + +unless (defined $libperl_a) { + skip_all "no libperl.a"; +} + +print "# \$^O = $^O\n"; +print "# \$Config{cc} = $Config{cc}\n"; +print "# libperl = $libperl_a\n"; + +my $nm; +my $nm_opt = ''; +my $nm_style; +my $nm_fh; +my $nm_err_tmp = "libperl$$"; + +END { + # this is still executed when we skip_all above, avoid a warning + unlink $nm_err_tmp if $nm_err_tmp; +} + +my $fake_input; +my $fake_style; + +if (@ARGV == 1) { + $fake_input = shift @ARGV; + print "# Faking nm output from $fake_input\n"; + if ($fake_input =~ s/\@(.+)$//) { + $fake_style = $1; + print "# Faking nm style from $fake_style\n"; + if ($fake_style eq 'gnu' || + $fake_style eq 'linux' || + $fake_style eq 'freebsd') { + $nm_style = 'gnu' + } elsif ($fake_style eq 'darwin' || $fake_style eq 'osx') { + $nm_style = 'darwin' + } else { + die "$0: Unknown explicit nm style '$fake_style'\n"; + } + } +} + +unless (defined $nm_style) { + if ($^O eq 'linux') { + # The 'gnu' style could be equally well be called 'bsd' style, + # since the output format of the GNU binutils nm is really BSD. + $nm_style = 'gnu'; + } elsif ($^O eq 'freebsd') { + $nm_style = 'gnu'; + } elsif ($^O eq 'darwin') { + $nm_style = 'darwin'; + } +} + +if (defined $nm_style) { + if ($nm_style eq 'gnu') { + $nm = '/usr/bin/nm'; + } elsif ($nm_style eq 'darwin') { + $nm = '/usr/bin/nm'; + # With the -m option we get better information than the BSD-like + # default: with the default, a lot of symbols get dumped into 'S' + # or 's', for example one cannot tell the difference between const + # and non-const data symbols. + $nm_opt = '-m'; + } else { + die "$0: Unexpected nm style '$nm_style'\n"; + } +} + +unless (defined $nm) { + skip_all "no nm"; +} + +unless (defined $nm_style) { + skip_all "no nm style"; +} + +print "# nm = $nm\n"; +print "# nm_style = $nm_style\n"; +print "# nm_opt = $nm_opt\n"; + +unless (-x $nm) { + skip_all "no executable nm $nm"; +} + +if ($nm_style eq 'gnu' && !defined $fake_style) { + open(my $gnu_verify, "$nm --version|") or + skip_all "nm failed: $!"; + my $gnu_verified; + while (<$gnu_verify>) { + if (/^GNU nm/) { + $gnu_verified = 1; + last; + } + } + unless ($gnu_verified) { + skip_all "no GNU nm"; + } +} + +if (defined $fake_input) { + if ($fake_input eq '-') { + open($nm_fh, "<&STDIN") or + skip_all "Duping STDIN failed: $!"; + } else { + open($nm_fh, "<", $fake_input) or + skip_all "Opening '$fake_input' failed: $!"; + } + undef $nm_err_tmp; # In this case there will be no nm errors. +} else { + open($nm_fh, "$nm $nm_opt $libperl_a 2>$nm_err_tmp |") or + skip_all "$nm $nm_opt $libperl_a failed: $!"; +} + +sub is_perlish_symbol { + $_[0] =~ /^(?:PL_|Perl|PerlIO)/; +} + +# XXX Implement "internal test" for this script (option -t?) +# to verify that the parsing does what it's intended to. + +sub nm_parse_gnu { + my $symbols = shift; + my $line = $_; + if (m{^(\w+\.o):$}) { + # object file name + $symbols->{obj}{$1}++; + $symbols->{o} = $1; + return; + } else { + die "$0: undefined current object: $line" + unless defined $symbols->{o}; + # 64-bit systems have 16 hexdigits, 32-bit systems have 8. + if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) { + if (/^[Rr] (\w+)$/) { + # R: read only (const) + $symbols->{data}{const}{$1}{$symbols->{o}}++; + } elsif (/^r .+$/) { + # Skip local const (read only). + } elsif (/^[Tti] (\w+)(\..+)?$/) { + $symbols->{text}{$1}{$symbols->{o}}++; + } elsif (/^C (\w+)$/) { + $symbols->{data}{common}{$1}{$symbols->{o}}++; + } elsif (/^[BbSs] (\w+)(\.\d+)?$/) { + # Bb: uninitialized data (bss) + # Ss: uninitialized data "for small objects" + $symbols->{data}{bss}{$1}{$symbols->{o}}++; + } elsif (/^0{16} D _LIB_VERSION$/) { + # Skip the _LIB_VERSION (not ours, probably libm) + } elsif (/^[DdGg] (\w+)$/) { + # Dd: initialized data + # Gg: initialized "for small objects" + $symbols->{data}{data}{$1}{$symbols->{o}}++; + } elsif (/^. \.?(\w+)$/) { + # Skip the unknown types. + print "# Unknown type: $line ($symbols->{o})\n"; + } + return; + } elsif (/^ {8}(?: {8})? U _?(\w+)$/) { + my ($symbol) = $1; + return if is_perlish_symbol($symbol); + $symbols->{undef}{$symbol}{$symbols->{o}}++; + return; + } + } + print "# Unexpected nm output '$line' ($symbols->{o})\n"; +} + +sub nm_parse_darwin { + my $symbols = shift; + my $line = $_; + if (m{^(?:.+)?libperl\.a\((\w+\.o)\):$}) { + # object file name + $symbols->{obj}{$1}++; + $symbols->{o} = $1; + return; + } else { + die "$0: undefined current object: $line" unless defined $symbols->{o}; + # 64-bit systems have 16 hexdigits, 32-bit systems have 8. + if (s/^[0-9a-f]{8}(?:[0-9a-f]{8})? //) { + # String literals can live in different sections + # depending on the compiler and os release, assumedly + # also linker flags. + if (/^\(__TEXT,__(?:const|cstring|literal\d+)\) (?:non-)?external _?(\w+)(\.\w+)?$/) { + my ($symbol, $suffix) = ($1, $2); + # Ignore function-local constants like + # _Perl_av_extend_guts.oom_array_extend + return if defined $suffix && /__TEXT,__const/; + # Ignore the cstring unnamed strings. + return if $symbol =~ /^L\.str\d+$/; + $symbols->{data}{const}{$symbol}{$symbols->{o}}++; + } elsif (/^\(__TEXT,__text\) (?:non-)?external _(\w+)$/) { + $symbols->{text}{$1}{$symbols->{o}}++; + } elsif (/^\(__DATA,__(const|data|bss|common)\) (?:non-)?external _(\w+)(\.\w+)?$/) { + my ($dtype, $symbol, $suffix) = ($1, $2, $3); + # Ignore function-local constants like + # _Perl_pp_gmtime.dayname + return if defined $suffix; + $symbols->{data}{$dtype}{$symbol}{$symbols->{o}}++; + } elsif (/^\(__DATA,__const\) non-external _\.memset_pattern\d*$/) { + # Skip this, whatever it is (some inlined leakage from + # darwin libc?) + } elsif (/^\(__TEXT,__eh_frame/) { + # Skip the eh_frame (exception handling) symbols. + return; + } elsif (/^\(__\w+,__\w+\) /) { + # Skip the unknown types. + print "# Unknown type: $line ($symbols->{o})\n"; + } + return; + } elsif (/^ {8}(?: {8})? \(undefined(?: \[lazy bound\])?\) external _?(.+)/) { + # darwin/ppc marks most undefined text symbols + # as "[lazy bound]". + my ($symbol) = $1; + return if is_perlish_symbol($symbol); + $symbols->{undef}{$symbol}{$symbols->{o}}++; + return; + } + } + print "# Unexpected nm output '$line' ($symbols->{o})\n"; +} + +my $nm_parse; + +if ($nm_style eq 'gnu') { + $nm_parse = \&nm_parse_gnu; +} elsif ($nm_style eq 'darwin') { + $nm_parse = \&nm_parse_darwin; +} + +unless (defined $nm_parse) { + skip_all "no nm parser ($nm_style $nm_style, \$^O $^O)"; +} + +my %symbols; + +while (<$nm_fh>) { + next if /^$/; + chomp; + $nm_parse->(\%symbols); +} + +# use Data::Dumper; print Dumper(\%symbols); + +if (keys %symbols == 0) { + skip_all "no symbols\n"; +} + +# These should always be true for everyone. + +ok($symbols{obj}{'pp.o'}, "has object pp.o"); +ok($symbols{text}{'Perl_peep'}, "has text Perl_peep"); +ok($symbols{text}{'Perl_pp_uc'}{'pp.o'}, "has text Perl_pp_uc in pp.o"); +ok(exists $symbols{data}{const}, "has data const symbols"); +ok($symbols{data}{const}{PL_no_mem}{'globals.o'}, "has PL_no_mem"); + +my $DEBUGGING = $Config{ccflags} =~ /-DDEBUGGING/ ? 1 : 0; + +my $GS = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT\b/ ? 1 : 0; +my $GSP = $Config{ccflags} =~ /-DPERL_GLOBAL_STRUCT_PRIVATE/ ? 1 : 0; + +print "# GS = $GS\n"; +print "# GSP = $GSP\n"; + +my %data_symbols; + +for my $dtype (sort keys %{$symbols{data}}) { + for my $symbol (sort keys %{$symbols{data}{$dtype}}) { + $data_symbols{$symbol}++; + } +} + +# The following tests differ between vanilla vs $GSP or $GS. + +if ($GSP) { + print "# -DPERL_GLOBAL_STRUCT_PRIVATE\n"; + ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed"); + ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr"); + + ok(! exists $symbols{data}{bss}, "has no data bss symbols"); + ok(! exists $symbols{data}{data} || + # clang with ASAN seems to add this symbol to every object file: + !grep($_ ne '__unnamed_1', keys %{$symbols{data}{data}}), + "has no data data symbols"); + ok(! exists $symbols{data}{common}, "has no data common symbols"); + + # -DPERL_GLOBAL_STRUCT_PRIVATE should NOT have + # the extra text symbol for accessing the vars + # (as opposed to "just" -DPERL_GLOBAL_STRUCT) + ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars"); +} elsif ($GS) { + print "# -DPERL_GLOBAL_STRUCT\n"; + ok(!exists $data_symbols{PL_hash_seed}, "has no PL_hash_seed"); + ok(!exists $data_symbols{PL_ppaddr}, "has no PL_ppaddr"); + + ok(! exists $symbols{data}{bss}, "has no data bss symbols"); + + # These PerlIO data symbols are left visible with + # -DPERL_GLOBAL_STRUCT (as opposed to -DPERL_GLOBAL_STRUCT_PRIVATE) + my @PerlIO = + qw( + PerlIO_byte + PerlIO_crlf + PerlIO_pending + PerlIO_perlio + PerlIO_raw + PerlIO_remove + PerlIO_stdio + PerlIO_unix + PerlIO_utf8 + ); + + # PL_magic_vtables is const with -DPERL_GLOBAL_STRUCT_PRIVATE but + # otherwise not const -- because of SWIG which wants to modify + # the table. Evil SWIG, eeevil. + + # my_cxt_index is used with PERL_IMPLICIT_CONTEXT, which + # -DPERL_GLOBAL_STRUCT has turned on. + eq_array([sort keys %{$symbols{data}{data}}], + [sort('PL_VarsPtr', + @PerlIO, + 'PL_magic_vtables', + 'my_cxt_index')], + "data data symbols"); + + # Only one data common symbol, our "supervariable". + eq_array([sort keys %{$symbols{data}{common}}], + ['PL_Vars'], + "data common symbols"); + + ok($symbols{data}{data}{PL_VarsPtr}{'globals.o'}, "has PL_VarsPtr"); + ok($symbols{data}{common}{PL_Vars}{'globals.o'}, "has PL_Vars"); + + # -DPERL_GLOBAL_STRUCT has extra text symbol for accessing the vars. + ok($symbols{text}{Perl_GetVars}{'util.o'}, "has Perl_GetVars"); +} else { + print "# neither -DPERL_GLOBAL_STRUCT nor -DPERL_GLOBAL_STRUCT_PRIVATE\n"; + + if ( !$symbols{data}{common} ) { + # This is likely because Perl was compiled with + # -Accflags="-fno-common" + $symbols{data}{common} = $symbols{data}{bss}; + } + + ok($symbols{data}{common}{PL_hash_seed}{'globals.o'}, "has PL_hash_seed"); + ok($symbols{data}{data}{PL_ppaddr}{'globals.o'}, "has PL_ppaddr"); + + # None of the GLOBAL_STRUCT* business here. + ok(! exists $symbols{data}{data}{PL_VarsPtr}, "has no PL_VarsPtr"); + ok(! exists $symbols{data}{common}{PL_Vars}, "has no PL_Vars"); + ok(! exists $symbols{text}{Perl_GetVars}, "has no Perl_GetVars"); +} + +ok(keys %{$symbols{undef}}, "has undefined symbols"); + +# memchr, memcmp, memcpy should be used all over the place. +# +# chmod, socket, getenv, sigaction, time are system/library +# calls that should each see at least one use. +my @good = qw(memchr memcmp memcpy + chmod socket getenv sigaction time); +if ($Config{usedl}) { + push @good, 'dlopen'; +} +for my $good (@good) { + my @o = exists $symbols{undef}{$good} ? + sort keys %{ $symbols{undef}{$good} } : (); + ok(@o, "uses $good (@o)"); +} + +# gets is horribly unsafe. +# +# fgets should not be used (Perl has its own API), even without perlio. +# +# tmpfile is unsafe. +# +# strcpy, strcat, strncpy, strncpy are unsafe. +# +# sprintf and vsprintf should not be used because +# Perl has its own safer and more portable implementations. +# (One exception: for certain floating point outputs +# the native sprintf is still used, see below.) +# +# XXX: add atoi() to @bad - unsafe and undefined failure modes. +# +my @bad = qw(gets fgets + tmpfile + strcpy strcat strncpy strncat tmpfile + sprintf vsprintf); +for my $bad (@bad) { + my @o = exists $symbols{undef}{$bad} ? + sort keys %{ $symbols{undef}{$bad} } : (); + # While sprintf() is bad in the general case, + # some platforms implement Gconvert via sprintf, in sv.o. + if ($bad eq 'sprintf' && + $Config{d_Gconvert} =~ /^sprintf/ && + @o == 1 && $o[0] eq 'sv.o') { + SKIP: { + skip("uses sprintf for Gconvert in sv.o"); + } + } else { + is(@o, 0, "uses no $bad (@o)"); + } +} + +if (defined $nm_err_tmp) { + if (open(my $nm_err_fh, $nm_err_tmp)) { + my $error; + while (<$nm_err_fh>) { + # OS X has weird error where nm warns about + # "no name list" but then outputs fine. + if (/nm: no name list/ && $^O eq 'darwin') { + print "# $^O ignoring $nm output: $_"; + next; + } + warn "$0: Unexpected $nm error: $_"; + $error++; + } + die "$0: Unexpected $nm errors\n" if $error; + } else { + warn "Failed to open '$nm_err_tmp': $!\n"; + } +} + +done_testing(); diff --git a/t/re/pat_advanced.t b/t/re/pat_advanced.t index 75c5744..82f0917 100644 --- a/t/re/pat_advanced.t +++ b/t/re/pat_advanced.t @@ -29,6 +29,8 @@ run_tests() unless caller; sub run_tests { { + no warnings 'deprecated'; + my $message = '\C matches octet'; $_ = "a\x{100}b"; ok(/(.)(\C)(\C)(.)/, $message); @@ -51,6 +53,8 @@ sub run_tests { } { + no warnings 'deprecated'; + my $message = '\C matches octet'; $_ = "\x{100}"; ok(/(\C)/g, $message); @@ -280,6 +284,8 @@ sub run_tests { } { + no warnings 'deprecated'; + my $message = '. matches \n with /s'; my $str1 = "foo\nbar"; my $str2 = "foo\n\x{100}bar"; @@ -486,6 +492,8 @@ sub run_tests { =~ /^(\X)!/ && $1 eq "\N{LATIN CAPITAL LETTER E}\N{COMBINING GRAVE ACCENT}", $message); + no warnings 'deprecated'; + $message = '\C and \X'; like("!abc!", qr/a\Cc/, $message); like("!abc!", qr/a\Xc/, $message); @@ -544,10 +552,13 @@ sub run_tests { $& eq "Francais", $message); ok("Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ /Fran.ais/ && $& eq "Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais", $message); - ok("Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran\Cais/ && - $& eq "Francais", $message); - # COMBINING CEDILLA is two bytes when encoded - like("Franc\N{COMBINING CEDILLA}ais", qr/Franc\C\Cais/, $message); + { + no warnings 'deprecated'; + ok("Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran\Cais/ && + $& eq "Francais", $message); + # COMBINING CEDILLA is two bytes when encoded + like("Franc\N{COMBINING CEDILLA}ais", qr/Franc\C\Cais/, $message); + } ok("Fran\N{LATIN SMALL LETTER C}ais" =~ /Fran\Xais/ && $& eq "Francais", $message); ok("Fran\N{LATIN SMALL LETTER C WITH CEDILLA}ais" =~ /Fran\Xais/ && @@ -2191,7 +2202,7 @@ EOP { # This was failing unless an explicit /d was added my $p = qr/[\xE0_]/i; utf8::upgrade($p); - like("\xC0", $p, "Verify \"\\xC0\" =~ /[\\xE0_]/i; pattern in utf8"); + like("\xC0", qr/$p/, "Verify \"\\xC0\" =~ /[\\xE0_]/i; pattern in utf8"); } ok "x" =~ /\A(?>(?:(?:)A|B|C?x))\z/, @@ -2432,7 +2443,7 @@ EOP { # Regexp:Grammars was broken: # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2013-06/msg01290.html fresh_perl_like('use warnings; "abc" =~ qr{(?&foo){0}abc(?)}', - 'Quantifier unexpected on zero-length expression', + qr/Quantifier unexpected on zero-length expression/, {}, 'No segfault on qr{(?&foo){0}abc(?)}'); } diff --git a/t/re/pat_rt_report.t b/t/re/pat_rt_report.t index 94100d1..ea9a306 100644 --- a/t/re/pat_rt_report.t +++ b/t/re/pat_rt_report.t @@ -91,6 +91,7 @@ sub run_tests { } { + no warnings 'deprecated'; my $message = '\C and É; Bug 20001230.002'; ok("École" =~ /^\C\C(.)/ && $1 eq 'c', $message); like("École", qr/^\C\C(c)/, $message); @@ -238,6 +239,8 @@ sub run_tests { chop $a; # Leaves the UTF-8 flag $a .= "y"; # 1 byte before 'y'. + no warnings 'deprecated'; + like($a, qr/^\C/, 'match one \C on 1-byte UTF-8; Bug 15763'); like($a, qr/^\C{1}/, 'match \C{1}; Bug 15763'); @@ -1172,7 +1175,10 @@ EOP # this one segfaulted under the conditions above # of course, CANY is evil, maybe it should crash - ok($s =~ /.\C+/, "CANY pointer wrap"); + { + no warnings 'deprecated'; + ok($s =~ /.\C+/, "CANY pointer wrap"); + } } } # End of sub run_tests diff --git a/t/re/re_tests b/t/re/re_tests index 78bacc9..964360d 100644 --- a/t/re/re_tests +++ b/t/re/re_tests @@ -134,6 +134,7 @@ a[^]b]c adc y $& adc \By\b xy y - - \by\B yz y - - \By\B xyz y - - +\B y - - \w a y - - \w - n - - \W a n - - @@ -1057,6 +1058,7 @@ X(?:ABCF[cC]x*|ABCD|ABCF):(?:DIT|DID|DIM) XABCFCxxxxxxxxxx:DIM y $& XABCFCxxxxxx (?=foo) foo y pos 0 (?=foo) XfooY y pos 1 .*(?=foo) XfooY y pos 1 +(?=.*P)P aP y pos 2 (?<=foo) foo y pos 3 (?<=foo) XfooY y pos 4 .*(?<=foo) foo y pos 3 diff --git a/t/re/reg_fold.t b/t/re/reg_fold.t index 5da8cd2..3e98866 100644 --- a/t/re/reg_fold.t +++ b/t/re/reg_fold.t @@ -155,7 +155,7 @@ for my $i (0 .. 255) { push @tests, qq[like chr(0x0430), qr/[=\x{0410}-\x{0411}]/i, 'Bug #71752 Unicode /i char in a range']; push @tests, qq[like 'a', qr/\\p{Upper}/i, "'a' =~ /\\\\p{Upper}/i"]; -push @tests, q[my $c = "\x{212A}"; my $p = qr/(?:^[K_]+$)/i; utf8::upgrade($p); like $c, $p, 'Bug #78994: my $c = "\x{212A}"; my $p = qr/(?:^[K_]+$)/i; utf8::upgrade($p); $c =~ $p']; +push @tests, q[my $c = "\x{212A}"; my $p = qr/(?:^[K_]+$)/i; utf8::upgrade($p); like $c, qr/$p/, 'Bug #78994: my $c = "\x{212A}"; my $p = qr/(?:^[K_]+$)/i; utf8::upgrade($p); $c =~ $p']; use charnames ":full"; my $e_grave = latin1_to_native("\xE8"); diff --git a/t/re/subst.t b/t/re/subst.t index 244bcad..85fe5d6 100644 --- a/t/re/subst.t +++ b/t/re/subst.t @@ -5,9 +5,10 @@ BEGIN { @INC = '../lib'; require Config; import Config; require './test.pl'; + require './charset_tools.pl'; } -plan( tests => 236 ); +plan( tests => 260 ); $_ = 'david'; $a = s/david/rules/r; @@ -1002,3 +1003,50 @@ like $@, qr/^Modification of a read-only value/, eval { for (__PACKAGE__) { s/b/c/; } }; like $@, qr/^Modification of a read-only value/, 'read-only COW =~ s/does not match// should croak'; + +SKIP: { + my $a_acute = chr utf8::unicode_to_native(0xE1); # LATIN SMALL LETTER A WITH ACUTE + my $egrave = chr utf8::unicode_to_native(0xE8); # LATIN SMALL LETTER E WITH GRAVE + my $u_umlaut = chr utf8::unicode_to_native(0xFC); # LATIN SMALL LETTER U WITH DIAERESIS + my $division = chr utf8::unicode_to_native(0xF7); # DIVISION SIGN + + is("ab.c" =~ s/\b/!/agr, "!ab!.!c!", '\\b matches ASCII before string, mid, and end, /a'); + is("$a_acute$egrave.$u_umlaut" =~ s/\b/!/agr, "$a_acute$egrave.$u_umlaut", '\\b matches Latin1 before string, mid, and end, /a'); + is("\x{100}\x{101}.\x{102}" =~ s/\b/!/agr, "\x{100}\x{101}.\x{102}", '\\b matches above-Latin1 before string, mid, and end, /a'); + + is("..." =~ s/\B/!/agr, "!.!.!.!", '\\B matches ASCII before string, mid, and end, /a'); + is("$division$division$division" =~ s/\B/!/agr, "!$division!$division!$division!", '\\B matches Latin1 before string, mid, and end, /a'); + is("\x{2028}\x{2028}\x{2028}" =~ s/\B/!/agr, "!\x{2028}!\x{2028}!\x{2028}!", '\\B matches above-Latin1 before string, mid, and end, /a'); + + is("ab.c" =~ s/\b/!/dgr, "!ab!.!c!", '\\b matches ASCII before string, mid, and end, /d'); + { is("$a_acute$egrave.$u_umlaut" =~ s/\b/!/dgr, "$a_acute$egrave.$u_umlaut", '\\b matches Latin1 before string, mid, and end, /d'); } + is("\x{100}\x{101}.\x{102}" =~ s/\b/!/dgr, "!\x{100}\x{101}!.!\x{102}!", '\\b matches above-Latin1 before string, mid, and end, /d'); + + is("..." =~ s/\B/!/dgr, "!.!.!.!", '\\B matches ASCII before string, mid, and end, /d'); + is("$division$division$division" =~ s/\B/!/dgr, "!$division!$division!$division!", '\\B matches Latin1 before string, mid, and end, /d'); + is("\x{2028}\x{2028}\x{2028}" =~ s/\B/!/dgr, "!\x{2028}!\x{2028}!\x{2028}!", '\\B matches above-Latin1 before string, mid, and end, /d'); + + is("ab.c" =~ s/\b/!/ugr, "!ab!.!c!", '\\b matches ASCII before string, mid, and end, /u'); + is("$a_acute$egrave.$u_umlaut" =~ s/\b/!/ugr, "!$a_acute$egrave!.!$u_umlaut!", '\\b matches Latin1 before string, mid, and end, /u'); + is("\x{100}\x{101}.\x{102}" =~ s/\b/!/ugr, "!\x{100}\x{101}!.!\x{102}!", '\\b matches above-Latin1 before string, mid, and end, /u'); + + is("..." =~ s/\B/!/ugr, "!.!.!.!", '\\B matches ASCII before string, mid, and end, /u'); + 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'); + +SKIP: { + eval { require POSIX; POSIX->import("locale_h"); }; + if ($@) { skip "Can't test locale (maybe you are missing POSIX)", 6; } + + setlocale(&POSIX::LC_ALL, "C"); + use locale; + is("a.b" =~ s/\b/!/gr, "!a!.!b!", '\\b matches ASCII before string, mid, and end, /l'); + is("$a_acute.$egrave" =~ s/\b/!/gr, "$a_acute.$egrave", '\\b matches Latin1 before string, mid, and end, /l'); + is("\x{100}\x{101}.\x{102}" =~ s/\b/!/gr, "!\x{100}\x{101}!.!\x{102}!", '\\b matches above-Latin1 before string, mid, and end, /l'); + + is("..." =~ s/\B/!/gr, "!.!.!.!", '\\B matches ASCII before string, mid, and end, /l'); + is("$division$division$division" =~ s/\B/!/gr, "!$division!$division!$division!", '\\B matches Latin1 before string, mid, and end, /l'); + is("\x{2028}\x{2028}\x{2028}" =~ s/\B/!/gr, "!\x{2028}!\x{2028}!\x{2028}!", '\\B matches above-Latin1 before string, mid, and end, /l'); +} + +} diff --git a/t/run/locale.t b/t/run/locale.t index ef88ea6..47bd1a3 100644 --- a/t/run/locale.t +++ b/t/run/locale.t @@ -25,6 +25,22 @@ my @locales = eval { find_locales( [ &LC_ALL, &LC_CTYPE, &LC_NUMERIC ] ) }; skip_all("no locales available") unless @locales; plan tests => &last; + +my $non_C_locale; +foreach my $locale (@locales) { + next if $locale eq "C" || $locale eq 'POSIX'; + $non_C_locale = $locale; + last; +} + +SKIP: { + skip("no non-C locale available", 2 ) unless $non_C_locale; + setlocale(LC_NUMERIC, $non_C_locale); + isnt(setlocale(LC_NUMERIC), "C", "retrieving current non-C LC_NUMERIC doesn't give 'C'"); + setlocale(LC_ALL, $non_C_locale); + isnt(setlocale(LC_ALL), "C", "retrieving current non-C LC_ALL doesn't give 'C'"); +} + fresh_perl_is("for (qw(@locales)) {\n" . <<'EOF', use POSIX qw(locale_h); use locale; @@ -94,8 +110,8 @@ SKIP: { } SKIP: { - skip("no locale available where LC_NUMERIC makes a difference", &last - 5 ) - if !$different; # -5 is 3 tests before this block; 2 after + skip("no locale available where LC_NUMERIC makes a difference", &last - 7 ) + if !$different; # -7 is 5 tests before this block; 2 after note("using the '$different' locale for LC_NUMERIC tests"); { local $ENV{LC_NUMERIC} = $different; @@ -408,4 +424,7 @@ EOF } -sub last { 35 } +# IMPORTANT: When adding tests before the following line, be sure to update +# its skip count: +# skip("no locale available where LC_NUMERIC makes a difference", ...) +sub last { 37 } diff --git a/t/test.pl b/t/test.pl index 2b56623..13db432 100644 --- a/t/test.pl +++ b/t/test.pl @@ -53,6 +53,7 @@ sub plan { } } else { my %plan = @_; + $plan{skip_all} and skip_all($plan{skip_all}); $n = $plan{tests}; } _print "1..$n\n" unless $noplan; @@ -420,6 +421,14 @@ sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- sub like_yn ($$$@) { my ($flip, undef, $expected, $name, @mess) = @_; + + # We just accept like(..., qr/.../), not like(..., '...'), and + # definitely not like(..., '/.../') like + # Test::Builder::maybe_regex() does. + unless (re::is_regexp($expected)) { + die "PANIC: The value '$expected' isn't a regexp. The like() function needs a qr// pattern, not a string"; + } + my $pass; $pass = $_[1] =~ /$expected/ if !$flip; $pass = $_[1] !~ /$expected/ if $flip; diff --git a/t/test_pl/plan_skip_all.t b/t/test_pl/plan_skip_all.t new file mode 100644 index 0000000..fddb8f0 --- /dev/null +++ b/t/test_pl/plan_skip_all.t @@ -0,0 +1,7 @@ +#!/usr/bin/env perl -w +use strict; +use warnings; + +BEGIN { require "test.pl"; } + +plan skip_all => "Test Test::More compatible plan skip_all => \$foo"; diff --git a/t/uni/attrs.t b/t/uni/attrs.t index 3ea2f68..be064b9 100644 --- a/t/uni/attrs.t +++ b/t/uni/attrs.t @@ -61,10 +61,10 @@ eval 'my A $x : plǖgh;'; is $@, ''; eval 'package Càt; my Càt @socks;'; -like $@, ''; +is $@, ''; eval 'my Càt %nap;'; -like $@, ''; +is $@, ''; sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } sub X::ᕘ { 1 } diff --git a/t/uni/readline.t b/t/uni/readline.t index a83558e..f865bc0 100644 --- a/t/uni/readline.t +++ b/t/uni/readline.t @@ -15,7 +15,7 @@ use open qw( :utf8 :std ); # TARG. Test that we respect SvREADONLY. use constant roref=>\2; eval { for (roref) { $_ = } }; -like($@, 'Modification of a read-only value attempted', '[perl #19566]'); +like($@, qr/Modification of a read-only value attempted/, '[perl #19566]'); # [perl #21628] { diff --git a/taint.c b/taint.c index f21f5be..a5194f4 100644 --- a/taint.c +++ b/taint.c @@ -79,7 +79,6 @@ Perl_taint_proper(pTHX_ const char *f, const char *const s) void Perl_taint_env(pTHX) { - dVAR; SV** svp; MAGIC* mg; const char* const *e; diff --git a/time64.c b/time64.c index 72a5a97..74914bd 100644 --- a/time64.c +++ b/time64.c @@ -300,8 +300,8 @@ static void S_copy_little_tm_to_big_TM(const struct tm *src, struct TM *dest) { #ifndef HAS_LOCALTIME_R /* Simulate localtime_r() to the best of our ability */ static struct tm * S_localtime_r(const time_t *clock, struct tm *result) { -#ifdef VMS - dTHX; /* in case the following is defined as Perl_my_localtime(aTHX_ ...) */ +#ifdef __VMS + dTHX; /* the following is defined as Perl_my_localtime(aTHX_ ...) */ #endif const struct tm *static_result = localtime(clock); @@ -321,7 +321,9 @@ static struct tm * S_localtime_r(const time_t *clock, struct tm *result) { #ifndef HAS_GMTIME_R /* Simulate gmtime_r() to the best of our ability */ static struct tm * S_gmtime_r(const time_t *clock, struct tm *result) { - dTHX; /* in case the following is defined as Perl_my_gmtime(aTHX_ ...) */ +#ifdef __VMS + dTHX; /* the following is defined as Perl_my_localtime(aTHX_ ...) */ +#endif const struct tm *static_result = gmtime(clock); assert(result != NULL); diff --git a/toke.c b/toke.c index 44293de..2842115 100644 --- a/toke.c +++ b/toke.c @@ -474,7 +474,6 @@ S_deprecate_commaless_var_list(pTHX) { STATIC int S_ao(pTHX_ int toketype) { - dVAR; if (*PL_bufptr == '=') { PL_bufptr++; if (toketype == ANDAND) @@ -504,7 +503,6 @@ S_ao(pTHX_ int toketype) STATIC void S_no_op(pTHX_ const char *const what, char *s) { - dVAR; char * const oldbp = PL_bufptr; const bool is_first = (PL_oldbufptr == PL_linestart); @@ -551,7 +549,6 @@ S_no_op(pTHX_ const char *const what, char *s) STATIC void S_missingterm(pTHX_ char *s) { - dVAR; char tmpbuf[3]; char q; if (s) { @@ -582,7 +579,6 @@ S_missingterm(pTHX_ char *s) bool Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen) { - dVAR; char he_name[8 + MAX_FEATURE_LEN] = "feature_"; PERL_ARGS_ASSERT_FEATURE_IS_ENABLED; @@ -674,7 +670,6 @@ used by perl internally, so extensions should always pass zero. void Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags) { - dVAR; const char *s = NULL; yy_parser *parser, *oparser; if (flags && flags & ~LEX_START_FLAGS) @@ -1638,7 +1633,6 @@ Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn) STATIC void S_incline(pTHX_ const char *s) { - dVAR; const char *t; const char *n; const char *e; @@ -1823,7 +1817,6 @@ S_skipspace_flags(pTHX_ char *s, U32 flags) STATIC void S_check_uni(pTHX) { - dVAR; const char *s; const char *t; @@ -1860,8 +1853,6 @@ S_check_uni(pTHX) STATIC I32 S_lop(pTHX_ I32 f, int x, char *s) { - dVAR; - PERL_ARGS_ASSERT_LOP; pl_yylval.ival = f; @@ -1897,7 +1888,6 @@ S_lop(pTHX_ I32 f, int x, char *s) STATIC void S_force_next(pTHX_ I32 type) { - dVAR; #ifdef DEBUGGING if (DEBUG_T_TEST) { PerlIO_printf(Perl_debug_log, "### forced token:\n"); @@ -1925,7 +1915,6 @@ S_force_next(pTHX_ I32 type) static int S_postderef(pTHX_ int const funny, char const next) { - dVAR; assert(funny == DOLSHARP || strchr("$@%&*", funny)); assert(strchr("*[{", next)); if (next == '*') { @@ -1972,7 +1961,6 @@ Perl_yyunlex(pTHX) STATIC SV * S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len) { - dVAR; SV * const sv = newSVpvn_utf8(start, len, !IN_BYTES && UTF @@ -2001,7 +1989,6 @@ S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len) STATIC char * S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack) { - dVAR; char *s; STRLEN len; @@ -2049,8 +2036,6 @@ S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack) STATIC void S_force_ident(pTHX_ const char *s, int kind) { - dVAR; - PERL_ARGS_ASSERT_FORCE_IDENT; if (s[0]) { @@ -2122,7 +2107,6 @@ Perl_str_to_version(pTHX_ SV *sv) STATIC char * S_force_version(pTHX_ char *s, int guessing) { - dVAR; OP *version = NULL; char *d; @@ -2167,7 +2151,6 @@ S_force_version(pTHX_ char *s, int guessing) STATIC char * S_force_strict_version(pTHX_ char *s) { - dVAR; OP *version = NULL; const char *errstr = NULL; @@ -2208,7 +2191,6 @@ S_force_strict_version(pTHX_ char *s) STATIC SV * S_tokeq(pTHX_ SV *sv) { - dVAR; char *s; char *send; char *d; @@ -2279,7 +2261,6 @@ S_tokeq(pTHX_ SV *sv) STATIC I32 S_sublex_start(pTHX) { - dVAR; const I32 op_type = pl_yylval.ival; if (op_type == OP_NULL) { @@ -2329,7 +2310,6 @@ S_sublex_start(pTHX) STATIC I32 S_sublex_push(pTHX) { - dVAR; LEXSHARED *shared; const bool is_heredoc = PL_multi_close == '<'; ENTER; @@ -2426,7 +2406,6 @@ S_sublex_push(pTHX) STATIC I32 S_sublex_done(pTHX) { - dVAR; if (!PL_lex_starts++) { SV * const sv = newSVpvs(""); if (SvUTF8(PL_linestr)) @@ -2806,22 +2785,20 @@ S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e) STATIC char * S_scan_const(pTHX_ char *start) { - dVAR; char *send = PL_bufend; /* end of the constant */ - SV *sv = newSV(send - start); /* sv for the constant. See - note below on sizing. */ + SV *sv = newSV(send - start); /* sv for the constant. See note below + on sizing. */ char *s = start; /* start of the constant */ char *d = SvPVX(sv); /* destination for copies */ - bool dorange = FALSE; /* are we in a translit range? */ - bool didrange = FALSE; /* did we just finish a range? */ - bool in_charclass = FALSE; /* within /[...]/ */ - bool has_utf8 = FALSE; /* Output constant is UTF8 */ - bool this_utf8 = cBOOL(UTF); /* Is the source string assumed - to be UTF8? But, this can - show as true when the source - isn't utf8, as for example - when it is entirely composed - of hex constants */ + bool dorange = FALSE; /* are we in a translit range? */ + bool didrange = FALSE; /* did we just finish a range? */ + bool in_charclass = FALSE; /* within /[...]/ */ + bool has_utf8 = FALSE; /* Output constant is UTF8 */ + bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be + UTF8? But, this can show as true + when the source isn't utf8, as for + example when it is entirely composed + of hex constants */ SV *res; /* result from charnames */ /* Note on sizing: The scanned constant is placed into sv, which is @@ -2889,9 +2866,9 @@ S_scan_const(pTHX_ char *start) i = d - SvPVX_const(sv); /* remember current offset */ #ifdef EBCDIC SvGROW(sv, - SvLEN(sv) + (has_utf8 ? - (512 - UTF_CONTINUATION_MARK + - UNISKIP(0x100)) + SvLEN(sv) + ((has_utf8) + ? (512 - UTF_CONTINUATION_MARK + + UNISKIP(0x100)) : 256)); /* How many two-byte within 0..255: 128 in UTF-8, * 96 in UTF-8-mod. */ @@ -2932,6 +2909,8 @@ S_scan_const(pTHX_ char *start) } #ifdef EBCDIC + /* Because of the discontinuities in EBCDIC A-Z and a-z, expand + * any subsets of these ranges into individual characters */ if (literal_endpoint == 2 && ((isLOWER_A(min) && isLOWER_A(max)) || (isUPPER_A(min) && isUPPER_A(max)))) @@ -3379,8 +3358,11 @@ S_scan_const(pTHX_ char *start) d += 5; while (str < str_end) { char hex_string[4]; - my_snprintf(hex_string, sizeof(hex_string), - "%02X.", (U8) *str); + int len = + my_snprintf(hex_string, + sizeof(hex_string), + "%02X.", (U8) *str); + PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(hex_string)); Copy(hex_string, d, 3, char); d += 3; str++; @@ -3669,8 +3651,6 @@ S_scan_const(pTHX_ char *start) STATIC int S_intuit_more(pTHX_ char *s) { - dVAR; - PERL_ARGS_ASSERT_INTUIT_MORE; if (PL_lex_brackets) @@ -3831,7 +3811,6 @@ S_intuit_more(pTHX_ char *s) STATIC int S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) { - dVAR; char *s = start + (*start == '$'); char tmpbuf[sizeof PL_tokenbuf]; STRLEN len; @@ -3914,7 +3893,6 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) SV * Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) { - dVAR; if (!funcp) return NULL; @@ -3983,7 +3961,6 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) void Perl_filter_del(pTHX_ filter_t funcp) { - dVAR; SV *datasv; PERL_ARGS_ASSERT_FILTER_DEL; @@ -4011,7 +3988,6 @@ Perl_filter_del(pTHX_ filter_t funcp) I32 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) { - dVAR; filter_t funcp; SV *datasv = NULL; /* This API is bad. It should have been using unsigned int for maxlen. @@ -4101,8 +4077,6 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) STATIC char * S_filter_gets(pTHX_ SV *sv, STRLEN append) { - dVAR; - PERL_ARGS_ASSERT_FILTER_GETS; #ifdef PERL_CR_FILTER @@ -4125,7 +4099,6 @@ S_filter_gets(pTHX_ SV *sv, STRLEN append) STATIC HV * S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len) { - dVAR; GV *gv; PERL_ARGS_ASSERT_FIND_IN_MY_STASH; @@ -4154,8 +4127,6 @@ S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len) STATIC char * S_tokenize_use(pTHX_ int is_use, char *s) { - dVAR; - PERL_ARGS_ASSERT_TOKENIZE_USE; if (PL_expect != XSTATE) @@ -4586,7 +4557,7 @@ Perl_yylex(pTHX) : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s); len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart); if (len > UNRECOGNIZED_PRECEDE_COUNT) { - d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT; + d = UTF ? (char *) utf8_hop((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT; } else { d = PL_linestart; } @@ -7438,8 +7409,10 @@ Perl_yylex(pTHX) PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len); if (!PL_in_my_stash) { char tmpbuf[1024]; + int len; PL_bufptr = s; - my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf); + len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf); + PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf)); yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0); } } @@ -8105,7 +8078,6 @@ Perl_yylex(pTHX) static int S_pending_ident(pTHX) { - dVAR; PADOFFSET tmp = 0; const char pit = (char)pl_yylval.ival; const STRLEN tokenbuf_len = strlen(PL_tokenbuf); @@ -8225,8 +8197,6 @@ S_pending_ident(pTHX) STATIC void S_checkcomma(pTHX_ const char *s, const char *name, const char *what) { - dVAR; - PERL_ARGS_ASSERT_CHECKCOMMA; if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ @@ -8288,7 +8258,7 @@ STATIC SV * S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, SV *sv, SV *pv, const char *type, STRLEN typelen) { - dVAR; dSP; + dSP; HV * table = GvHV(PL_hintgv); /* ^H */ SV *res; SV *errsv = NULL; @@ -8424,7 +8394,6 @@ now_ok: PERL_STATIC_INLINE void S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) { - dVAR; PERL_ARGS_ASSERT_PARSE_IDENT; for (;;) { @@ -8476,7 +8445,6 @@ S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool STATIC char * S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) { - dVAR; char *d = dest; char * const e = d + destlen - 3; /* two-character token, ending NUL */ bool is_utf8 = cBOOL(UTF); @@ -8492,7 +8460,6 @@ S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN STATIC char * S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) { - dVAR; I32 herelines = PL_parser->herelines; SSize_t bracket = -1; char funny = *s++; @@ -8784,7 +8751,6 @@ S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charse STATIC char * S_scan_pat(pTHX_ char *start, I32 type) { - dVAR; PMOP *pm; char *s; const char * const valid_flags = @@ -8855,7 +8821,6 @@ S_scan_pat(pTHX_ char *start, I32 type) STATIC char * S_scan_subst(pTHX_ char *start) { - dVAR; char *s; PMOP *pm; I32 first_start; @@ -8938,7 +8903,6 @@ S_scan_subst(pTHX_ char *start) STATIC char * S_scan_trans(pTHX_ char *start) { - dVAR; char* s; OP *o; U8 squash; @@ -9028,7 +8992,6 @@ S_scan_trans(pTHX_ char *start) STATIC char * S_scan_heredoc(pTHX_ char *s) { - dVAR; I32 op_type = OP_SCALAR; I32 len; SV *tmpstr; @@ -9301,7 +9264,6 @@ S_scan_heredoc(pTHX_ char *s) STATIC char * S_scan_inputsymbol(pTHX_ char *start) { - dVAR; char *s = start; /* current position in buffer */ char *end; I32 len; @@ -9493,7 +9455,6 @@ S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re char **delimp ) { - dVAR; SV *sv; /* scalar value: string */ const char *tmps; /* temp string, used for delimiter matching */ char *s = start; /* current position in the buffer */ @@ -9831,7 +9792,6 @@ S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re char * Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) { - dVAR; const char *s = start; /* current position in buffer */ char *d; /* destination in temp buffer */ char *e; /* end of temp buffer */ @@ -10210,7 +10170,6 @@ vstring: STATIC char * S_scan_formline(pTHX_ char *s) { - dVAR; char *eol; char *t; SV * const stuff = newSVpvs(""); @@ -10312,7 +10271,6 @@ S_scan_formline(pTHX_ char *s) I32 Perl_start_subparse(pTHX_ I32 is_format, U32 flags) { - dVAR; const I32 oldsavestack_ix = PL_savestack_ix; CV* const outsidecv = PL_compcv; @@ -10337,8 +10295,6 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) static int S_yywarn(pTHX_ const char *const s, U32 flags) { - dVAR; - PERL_ARGS_ASSERT_YYWARN; PL_in_eval |= EVAL_WARNONLY; @@ -10364,7 +10320,6 @@ Perl_yyerror_pv(pTHX_ const char *const s, U32 flags) int Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags) { - dVAR; const char *context = NULL; int contlen = -1; SV *msg; @@ -10469,7 +10424,6 @@ Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags) STATIC char* S_swallow_bom(pTHX_ U8 *s) { - dVAR; const STRLEN slen = SvCUR(PL_linestr); PERL_ARGS_ASSERT_SWALLOW_BOM; @@ -10561,7 +10515,6 @@ S_swallow_bom(pTHX_ U8 *s) static I32 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) { - dVAR; SV *const filter = FILTER_DATA(idx); /* We re-use this each time round, throwing the contents away before we return. */ @@ -10729,7 +10682,6 @@ sv_2mortal. char * Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv) { - dVAR; const char *pos = s; const char *start = s; diff --git a/uconfig.h b/uconfig.h index eb1839a..b5648d4 100644 --- a/uconfig.h +++ b/uconfig.h @@ -1090,6 +1090,13 @@ /*#define HASATTRIBUTE_UNUSED / **/ /*#define HASATTRIBUTE_WARN_UNUSED_RESULT / **/ +/* HAS_BACKTRACE: + * This symbol, if defined, indicates that the backtrace() routine is + * available to get a stack trace. The header must be + * included to use this routine. + */ +/*#define HAS_BACKTRACE / **/ + /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. @@ -1178,6 +1185,13 @@ /*#define HAS_CTIME_R / **/ #define CTIME_R_PROTO 0 /**/ +/* HAS_DLADDR: + * This symbol, if defined, indicates that the dladdr() routine is + * available to query dynamic linker information for an address. + * The header must be included to use this routine. + */ +/*#define HAS_DLADDR / **/ + /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. @@ -2680,6 +2694,12 @@ /*#define DIRNAMLEN / **/ #define Direntry_t struct dirent +/* I_EXECINFO: + * This symbol, if defined, indicates to the C program that it should + * include for backtrace() support. + */ +/*#define I_EXECINFO / **/ + /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . @@ -2818,6 +2838,26 @@ */ /*#define I_SYSUIO / **/ +/* I_TERMIO: + * This symbol, if defined, indicates that the program should include + * rather than . There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/* I_TERMIOS: + * This symbol, if defined, indicates that the program should include + * the POSIX termios.h rather than sgtty.h or termio.h. + * There are also differences in the ioctl() calls that depend on the + * value of this symbol. + */ +/* I_SGTTY: + * This symbol, if defined, indicates that the program should include + * rather than . There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/*#define I_TERMIO / **/ +/*#define I_TERMIOS / **/ +/*#define I_SGTTY / **/ + /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . @@ -3273,46 +3313,6 @@ /*#define PERL_VENDORLIB_EXP "" / **/ /*#define PERL_VENDORLIB_STEM "" / **/ -/* HAS_BACKTRACE: - * This symbol, if defined, indicates that the backtrace() routine is - * available to get a stack trace. The header must be - * included to use this routine. - */ -/*#define HAS_BACKTRACE / **/ - -/* HAS_DLADDR: - * This symbol, if defined, indicates that the dladdr() routine is - * available to get a stack trace. The header must be - * included to use this routine. - */ -/*#define HAS_DLADDR / **/ - -/* I_EXECINFO: - * This symbol, if defined, indicates to the C program that it should - * include for backtrace() support. - */ -/*#define I_EXECINFO / **/ - -/* I_TERMIO: - * This symbol, if defined, indicates that the program should include - * rather than . There are also differences in - * the ioctl() calls that depend on the value of this symbol. - */ -/* I_TERMIOS: - * This symbol, if defined, indicates that the program should include - * the POSIX termios.h rather than sgtty.h or termio.h. - * There are also differences in the ioctl() calls that depend on the - * value of this symbol. - */ -/* I_SGTTY: - * This symbol, if defined, indicates that the program should include - * rather than . There are also differences in - * the ioctl() calls that depend on the value of this symbol. - */ -/*#define I_TERMIO / **/ -/*#define I_TERMIOS / **/ -/*#define I_SGTTY / **/ - /* USE_CROSS_COMPILE: * This symbol, if defined, indicates that Perl is being cross-compiled. */ @@ -3809,11 +3809,6 @@ */ /*#define HAS_OFF64_T / **/ -/* HAS_PTRDIFF_T: - * This symbol will be defined if the C compiler supports ptrdiff_t. - */ -#define HAS_PTRDIFF_T /**/ - /* HAS_PRCTL: * This symbol, if defined, indicates that the prctl routine is * available to set process title. @@ -3846,6 +3841,11 @@ */ /*#define HAS_PTHREAD_ATTR_SETSCOPE / **/ +/* HAS_PTRDIFF_T: + * This symbol will be defined if the C compiler supports ptrdiff_t. + */ +#define HAS_PTRDIFF_T /**/ + /* HAS_READV: * This symbol, if defined, indicates that the readv routine is * available to do gather reads. You will also need @@ -4742,6 +4742,6 @@ #endif /* Generated from: - * a37f46da5285428077feb313bcbe68661740bac16d76fa658d723d9fcc91c2c4 config_h.SH + * 727eb338c23fdd320f556ca32fd7eb5473f68b6ce74db8cec7d83399a2621346 config_h.SH * 4b709c0b049c660c04c0932eaa8481f9ca6fdc697ec4ffaa86b7bef21ee886a8 uconfig.sh * ex: set ro: */ diff --git a/universal.c b/universal.c index 777a924..c219411 100644 --- a/universal.c +++ b/universal.c @@ -41,7 +41,6 @@ STATIC bool S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags) { - dVAR; const struct mro_meta *const meta = HvMROMETA(stash); HV *isa = meta->isa; const HV *our_stash; @@ -147,7 +146,6 @@ Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags) bool Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags) { - dVAR; HV *stash; PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN; @@ -331,7 +329,6 @@ Perl_croak_xs_usage(const CV *const cv, const char *const params) XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */ XS(XS_UNIVERSAL_isa) { - dVAR; dXSARGS; if (items != 2) @@ -352,7 +349,6 @@ XS(XS_UNIVERSAL_isa) XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */ XS(XS_UNIVERSAL_can) { - dVAR; dXSARGS; SV *sv; SV *rv; @@ -388,7 +384,7 @@ XS(XS_UNIVERSAL_can) else { pkg = gv_stashsv(sv, 0); if (!pkg) - pkg = gv_stashpv("UNIVERSAL", 0); + pkg = gv_stashpvs("UNIVERSAL", 0); } if (pkg) { @@ -404,7 +400,6 @@ XS(XS_UNIVERSAL_can) XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */ XS(XS_UNIVERSAL_DOES) { - dVAR; dXSARGS; PERL_UNUSED_ARG(cv); @@ -422,7 +417,6 @@ XS(XS_UNIVERSAL_DOES) XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_is_utf8) { - dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "sv"); @@ -440,7 +434,6 @@ XS(XS_utf8_is_utf8) XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_valid) { - dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "sv"); @@ -459,7 +452,6 @@ XS(XS_utf8_valid) XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_encode) { - dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "sv"); @@ -471,7 +463,6 @@ XS(XS_utf8_encode) XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_decode) { - dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "sv"); @@ -489,7 +480,6 @@ XS(XS_utf8_decode) XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_upgrade) { - dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "sv"); @@ -507,7 +497,6 @@ XS(XS_utf8_upgrade) XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_downgrade) { - dVAR; dXSARGS; if (items < 1 || items > 2) croak_xs_usage(cv, "sv, failok=0"); @@ -524,7 +513,6 @@ XS(XS_utf8_downgrade) XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_native_to_unicode) { - dVAR; dXSARGS; const UV uv = SvUV(ST(0)); @@ -538,7 +526,6 @@ XS(XS_utf8_native_to_unicode) XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_unicode_to_native) { - dVAR; dXSARGS; const UV uv = SvUV(ST(0)); @@ -552,7 +539,6 @@ XS(XS_utf8_unicode_to_native) XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ { - dVAR; dXSARGS; SV * const svz = ST(0); SV * sv; @@ -590,7 +576,6 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */ XS(XS_constant__make_const) /* This is dangerous stuff. */ { - dVAR; dXSARGS; SV * const svz = ST(0); SV * sv; @@ -621,7 +606,6 @@ XS(XS_constant__make_const) /* This is dangerous stuff. */ XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ { - dVAR; dXSARGS; SV * const svz = ST(0); SV * sv; @@ -647,7 +631,6 @@ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */ XS(XS_Internals_hv_clear_placehold) { - dVAR; dXSARGS; if (items != 1 || !SvROK(ST(0))) @@ -662,7 +645,6 @@ XS(XS_Internals_hv_clear_placehold) XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */ XS(XS_PerlIO_get_layers) { - dVAR; dXSARGS; if (items < 1 || items % 2 == 0) croak_xs_usage(cv, "filehandle[,args]"); @@ -789,7 +771,6 @@ XS(XS_PerlIO_get_layers) XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */ XS(XS_re_is_regexp) { - dVAR; dXSARGS; PERL_UNUSED_VAR(cv); @@ -808,7 +789,6 @@ XS(XS_re_regnames_count) { REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; SV * ret; - dVAR; dXSARGS; if (items != 0) @@ -830,7 +810,6 @@ XS(XS_re_regnames_count) XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */ XS(XS_re_regname) { - dVAR; dXSARGS; REGEXP * rx; U32 flags; @@ -863,7 +842,6 @@ XS(XS_re_regname) XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */ XS(XS_re_regnames) { - dVAR; dXSARGS; REGEXP * rx; U32 flags; @@ -919,7 +897,6 @@ XS(XS_re_regnames) XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */ XS(XS_re_regexp_pattern) { - dVAR; dXSARGS; REGEXP *re; @@ -1056,7 +1033,6 @@ static const struct xsub_details details[] = { void Perl_boot_core_UNIVERSAL(pTHX) { - dVAR; static const char file[] = __FILE__; const struct xsub_details *xsub = details; const struct xsub_details *end = C_ARRAY_END(details); diff --git a/utf8.c b/utf8.c index 1e8f3f9..279d96f 100644 --- a/utf8.c +++ b/utf8.c @@ -489,7 +489,6 @@ warn. UV Perl_utf8n_to_uvchr(pTHX_ const U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags) { - dVAR; const U8 * const s0 = s; U8 overflow_byte = '\0'; /* Save byte in case of overflow */ U8 * send; @@ -947,7 +946,6 @@ up past C, croaks. STRLEN Perl_utf8_length(pTHX_ const U8 *s, const U8 *e) { - dVAR; STRLEN len = 0; PERL_ARGS_ASSERT_UTF8_LENGTH; @@ -1010,11 +1008,10 @@ on the first byte of character or just after the last byte of a character. */ U8 * -Perl_utf8_hop(pTHX_ const U8 *s, I32 off) +Perl_utf8_hop(const U8 *s, I32 off) { PERL_ARGS_ASSERT_UTF8_HOP; - PERL_UNUSED_CONTEXT; /* Note: cannot use UTF8_IS_...() too eagerly here since e.g * the bitops (especially ~) can create illegal UTF-8. * In other words: in Perl UTF-8 is not just for Unicode. */ @@ -1057,7 +1054,6 @@ Perl_bytes_cmp_utf8(pTHX_ const U8 *b, STRLEN blen, const U8 *u, STRLEN ulen) const U8 *const uend = u + ulen; PERL_ARGS_ASSERT_BYTES_CMP_UTF8; - PERL_UNUSED_CONTEXT; while (b < bend && u < uend) { U8 c = *u++; @@ -1359,7 +1355,6 @@ Perl__is_uni_FOO(pTHX_ const U8 classnum, const UV c) bool Perl__is_utf8_idstart(pTHX_ const U8 *p) { - dVAR; PERL_ARGS_ASSERT__IS_UTF8_IDSTART; if (*p == '_') @@ -1454,8 +1449,6 @@ Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, const char S_ UV Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp) { - dVAR; - /* Convert the Unicode character whose ordinal is to its uppercase * version and store that in UTF-8 in

and its length in bytes in . * Note that the

needs to be at least UTF8_MAXBYTES_CASE+1 bytes since @@ -1477,8 +1470,6 @@ Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp) UV Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp) { - dVAR; - PERL_ARGS_ASSERT_TO_UNI_TITLE; if (c < 256) { @@ -1515,8 +1506,6 @@ S_to_lower_latin1(const U8 c, U8* p, STRLEN *lenp) UV Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp) { - dVAR; - PERL_ARGS_ASSERT_TO_UNI_LOWER; if (c < 256) { @@ -1642,8 +1631,6 @@ S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, * have been checked before this call for mal-formedness enough to assure * that. */ - dVAR; - PERL_ARGS_ASSERT_IS_UTF8_COMMON; /* The API should have included a length for the UTF-8 character in

, @@ -1679,8 +1666,6 @@ S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, bool Perl__is_utf8_FOO(pTHX_ const U8 classnum, const U8 *p) { - dVAR; - PERL_ARGS_ASSERT__IS_UTF8_FOO; assert(classnum < _FIRST_NON_SWASH_CC); @@ -1694,7 +1679,6 @@ Perl__is_utf8_FOO(pTHX_ const U8 classnum, const U8 *p) bool Perl__is_utf8_perl_idstart(pTHX_ const U8 *p) { - dVAR; SV* invlist = NULL; PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART; @@ -1708,8 +1692,6 @@ Perl__is_utf8_perl_idstart(pTHX_ const U8 *p) bool Perl__is_utf8_xidstart(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT__IS_UTF8_XIDSTART; if (*p == '_') @@ -1720,7 +1702,6 @@ Perl__is_utf8_xidstart(pTHX_ const U8 *p) bool Perl__is_utf8_perl_idcont(pTHX_ const U8 *p) { - dVAR; SV* invlist = NULL; PERL_ARGS_ASSERT__IS_UTF8_PERL_IDCONT; @@ -1734,8 +1715,6 @@ Perl__is_utf8_perl_idcont(pTHX_ const U8 *p) bool Perl__is_utf8_idcont(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT__IS_UTF8_IDCONT; return is_utf8_common(p, &PL_utf8_idcont, "IdContinue", NULL); @@ -1744,8 +1723,6 @@ Perl__is_utf8_idcont(pTHX_ const U8 *p) bool Perl__is_utf8_xidcont(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT__IS_UTF8_XIDCONT; return is_utf8_common(p, &PL_utf8_idcont, "XIdContinue", NULL); @@ -1754,8 +1731,6 @@ Perl__is_utf8_xidcont(pTHX_ const U8 *p) bool Perl__is_utf8_mark(pTHX_ const U8 *p) { - dVAR; - PERL_ARGS_ASSERT__IS_UTF8_MARK; return is_utf8_common(p, &PL_utf8_mark, "IsM", NULL); @@ -1792,7 +1767,6 @@ UV Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, const char *normal, const char *special) { - dVAR; STRLEN len = 0; const UV uv1 = valid_utf8_to_uvchr(p, NULL); @@ -1949,8 +1923,6 @@ Instead use L. UV Perl__to_utf8_upper_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags) { - dVAR; - UV result; PERL_ARGS_ASSERT__TO_UTF8_UPPER_FLAGS; @@ -2016,8 +1988,6 @@ Instead use L. UV Perl__to_utf8_title_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags) { - dVAR; - UV result; PERL_ARGS_ASSERT__TO_UTF8_TITLE_FLAGS; @@ -2084,8 +2054,6 @@ Perl__to_utf8_lower_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, bool flags { UV result; - dVAR; - PERL_ARGS_ASSERT__TO_UTF8_LOWER_FLAGS; if (flags && IN_UTF8_CTYPE_LOCALE) { @@ -2154,8 +2122,6 @@ Instead use L. UV Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags) { - dVAR; - UV result; PERL_ARGS_ASSERT__TO_UTF8_FOLD_FLAGS; @@ -2349,7 +2315,6 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m * * is only valid for binary properties */ - dVAR; SV* retval = &PL_sv_undef; HV* swash_hv = NULL; const int invlist_swash_boundary = @@ -2600,7 +2565,6 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m UV Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8) { - dVAR; HV *const hv = MUTABLE_HV(SvRV(swash)); U32 klen; U32 off; @@ -3906,7 +3870,6 @@ L (Case Mappings). I32 Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const char *s2, char **pe2, UV l2, bool u2, U32 flags) { - dVAR; const U8 *p1 = (const U8*)s1; /* Point to current char */ const U8 *p2 = (const U8*)s2; const U8 *g1 = NULL; /* goal for s1 */ diff --git a/utf8.h b/utf8.h index 2357fb0..613389c 100644 --- a/utf8.h +++ b/utf8.h @@ -485,7 +485,9 @@ Perl's extended UTF-8 means we can have start bytes up to FF. * U+10FFFF: \xF4\x8F\xBF\xBF \xF9\xA1\xBF\xBF\xBF max legal Unicode * U+110000: \xF4\x90\x80\x80 \xF9\xA2\xA0\xA0\xA0 * U+110001: \xF4\x90\x80\x81 \xF9\xA2\xA0\xA0\xA1 - */ + * + * BE AWARE that this test doesn't rule out malformed code points, in + * particular overlongs */ #ifdef EBCDIC /* Both versions assume well-formed UTF8 */ # define UTF8_IS_SUPER(s) (NATIVE_UTF8_TO_I8(* (U8*) (s)) >= 0xF9 \ && (NATIVE_UTF8_TO_I8(* (U8*) (s)) > 0xF9 \ diff --git a/util.c b/util.c index 4666233..4b48e62 100644 --- a/util.c +++ b/util.c @@ -315,8 +315,6 @@ Perl_safesysfree(Malloc_t where) { #ifdef ALWAYS_NEED_THX dTHX; -#else - dVAR; #endif DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); if (where) { @@ -473,25 +471,33 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) Malloc_t Perl_malloc (MEM_SIZE nbytes) { - dTHXs; +#ifdef PERL_IMPLICIT_SYS + dTHX; +#endif return (Malloc_t)PerlMem_malloc(nbytes); } Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) { - dTHXs; +#ifdef PERL_IMPLICIT_SYS + dTHX; +#endif return (Malloc_t)PerlMem_calloc(elements, size); } Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) { - dTHXs; +#ifdef PERL_IMPLICIT_SYS + dTHX; +#endif return (Malloc_t)PerlMem_realloc(where, nbytes); } Free_t Perl_mfree (Malloc_t where) { - dTHXs; +#ifdef PERL_IMPLICIT_SYS + dTHX; +#endif PerlMem_free(where); } @@ -622,7 +628,6 @@ Analyses the string in order to make fast searches on it using fbm_instr() void Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { - dVAR; const U8 *s; STRLEN i; STRLEN len; @@ -913,7 +918,6 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U char * Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) { - dVAR; PERL_ARGS_ASSERT_SCREAMINSTR; PERL_UNUSED_ARG(bigstr); PERL_UNUSED_ARG(littlestr); @@ -1184,7 +1188,6 @@ Perl_savesharedsvpv(pTHX_ SV *sv) STATIC SV * S_mess_alloc(pTHX) { - dVAR; SV *sv; XPVMG *any; @@ -1307,7 +1310,6 @@ const COP* Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, bool opnext) { - dVAR; /* Look for curop starting from o. cop is the last COP we've seen. */ /* opnext means that curop is actually the ->op_next of the op we are seeking. */ @@ -1321,7 +1323,7 @@ Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, if (o->op_flags & OPf_KIDS) { const OP *kid; - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { + for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) { const COP *new_cop; /* If the OP_NEXTSTATE has been optimised away we can still use it @@ -1370,7 +1372,6 @@ required) to modify and return C instead of allocating a new SV. SV * Perl_mess_sv(pTHX_ SV *basemsg, bool consume) { - dVAR; SV *sv; #if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR) @@ -1415,7 +1416,7 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) */ const COP *cop = - closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE); + closest_cop(PL_curcop, OP_SIBLING(PL_curcop), PL_op, FALSE); if (!cop) cop = PL_curcop; @@ -1462,7 +1463,6 @@ this function. SV * Perl_vmess(pTHX_ const char *pat, va_list *args) { - dVAR; SV * const sv = mess_alloc(); PERL_ARGS_ASSERT_VMESS; @@ -1474,7 +1474,6 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) void Perl_write_to_stderr(pTHX_ SV* msv) { - dVAR; IO *io; MAGIC *mg; @@ -1514,7 +1513,6 @@ S_with_queued_errors(pTHX_ SV *ex) STATIC bool S_invoke_exception_hook(pTHX_ SV *ex, bool warn) { - dVAR; HV *stash; GV *gv; CV *cv; @@ -1930,7 +1928,6 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) bool Perl_ckwarn(pTHX_ U32 w) { - dVAR; /* If lexical warnings have not been set, use $^W. */ if (isLEXWARN_off) return PL_dowarn & G_WARN_ON; @@ -1943,7 +1940,6 @@ Perl_ckwarn(pTHX_ U32 w) bool Perl_ckwarn_d(pTHX_ U32 w) { - dVAR; /* If lexical warnings have not been set then default classes warn. */ if (isLEXWARN_off) return TRUE; @@ -2296,7 +2292,6 @@ PerlIO * Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) { #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) - dVAR; int p[2]; I32 This, that; Pid_t pid; @@ -2437,7 +2432,6 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { - dVAR; int p[2]; I32 This, that; Pid_t pid; @@ -2609,8 +2603,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) void Perl_atfork_lock(void) { - dVAR; #if defined(USE_ITHREADS) + dVAR; /* locks must be held in locking order (if any) */ # ifdef USE_PERLIO MUTEX_LOCK(&PL_perlio_mutex); @@ -2626,8 +2620,8 @@ Perl_atfork_lock(void) void Perl_atfork_unlock(void) { - dVAR; #if defined(USE_ITHREADS) + dVAR; /* locks must be released in same order as in atfork_lock() */ # ifdef USE_PERLIO MUTEX_UNLOCK(&PL_perlio_mutex); @@ -2701,10 +2695,10 @@ dup2(int oldfd, int newfd) Sighandler_t Perl_rsignal(pTHX_ int signo, Sighandler_t handler) { - dVAR; struct sigaction act, oact; #ifdef USE_ITHREADS + dVAR; /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) return (Sighandler_t) SIG_ERR; @@ -2742,7 +2736,9 @@ Perl_rsignal_state(pTHX_ int signo) int Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) { +#ifdef USE_ITHREADS dVAR; +#endif struct sigaction act; PERL_ARGS_ASSERT_RSIGNAL_SAVE; @@ -2770,7 +2766,10 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) int Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) { +#ifdef USE_ITHREADS dVAR; +#endif + PERL_UNUSED_CONTEXT; #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) @@ -2852,7 +2851,6 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { - dVAR; int status; SV **svp; Pid_t pid; @@ -2909,7 +2907,6 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) I32 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { - dVAR; I32 result = 0; PERL_ARGS_ASSERT_WAIT4PID; #ifdef PERL_USES_PL_PIDSTATUS @@ -3124,7 +3121,6 @@ char* Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char *const *const search_ext, I32 flags) { - dVAR; const char *xfound = NULL; char *xfailed = NULL; char tmpbuf[MAXPATHLEN]; @@ -3344,8 +3340,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, void * Perl_get_context(void) { - dVAR; #if defined(USE_ITHREADS) + dVAR; # ifdef OLD_PTHREADS_API pthread_addr_t t; int error = pthread_getspecific(PL_thr_key, &t) @@ -3367,7 +3363,9 @@ Perl_get_context(void) void Perl_set_context(void *t) { +#if defined(USE_ITHREADS) dVAR; +#endif PERL_ARGS_ASSERT_SET_CONTEXT; #if defined(USE_ITHREADS) # ifdef I_MACH_CTHREADS @@ -3390,7 +3388,8 @@ Perl_set_context(void *t) struct perl_vars * Perl_GetVars(pTHX) { - return &PL_Vars; + PERL_UNUSED_CONTEXT; + return &PL_Vars; } #endif @@ -3450,7 +3449,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id) PERL_UNUSED_CONTEXT; return (vtbl_id < 0 || vtbl_id >= magic_vtable_max) - ? NULL : PL_magic_vtables + vtbl_id; + ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id; } I32 @@ -3617,13 +3616,12 @@ Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ * semantics (and overhead) of mktime(). */ void -Perl_mini_mktime(pTHX_ struct tm *ptm) +Perl_mini_mktime(struct tm *ptm) { int yearday; int secs; int month, mday, year, jday; int odd_cent, odd_year; - PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_MINI_MKTIME; @@ -3806,6 +3804,9 @@ char * Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) { #ifdef HAS_STRFTIME + + /* Note that yday and wday effectively are ignored by this function, as mini_mktime() overwrites them */ + char *buf; int buflen; struct tm mytm; @@ -3923,7 +3924,6 @@ int Perl_getcwd_sv(pTHX_ SV *sv) { #ifndef PERL_MICRO - dVAR; SvTAINTED_on(sv); PERL_ARGS_ASSERT_GETCWD_SV; @@ -4445,7 +4445,6 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) U32 Perl_seed(pTHX) { - dVAR; /* * This is really just a quick hack which grabs various garbage * values. It really should be a real hash algorithm which @@ -4526,7 +4525,6 @@ Perl_seed(pTHX) void Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer) { - dVAR; const char *env_pv; unsigned long i; @@ -4616,6 +4614,7 @@ Perl_init_global_struct(pTHX) # ifdef PERL_GLOBAL_STRUCT const IV nppaddr = C_ARRAY_LENGTH(Gppaddr); const IV ncheck = C_ARRAY_LENGTH(Gcheck); + PERL_UNUSED_CONTEXT; # ifdef PERL_GLOBAL_STRUCT_PRIVATE /* PerlMem_malloc() because can't use even safesysmalloc() this early. */ plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars)); @@ -4673,6 +4672,7 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) int veto = plvarsp->Gveto_cleanup; PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT; + PERL_UNUSED_CONTEXT; # ifdef PERL_GLOBAL_STRUCT # ifdef PERL_UNSET_VARS PERL_UNSET_VARS(plvarsp); @@ -4921,6 +4921,9 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) int retval; va_list ap; PERL_ARGS_ASSERT_MY_SNPRINTF; +#ifndef HAS_VSNPRINTF + PERL_UNUSED_VAR(len); +#endif va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); @@ -4959,7 +4962,9 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap va_list apc; PERL_ARGS_ASSERT_MY_VSNPRINTF; - +#ifndef HAS_VSNPRINTF + PERL_UNUSED_VAR(len); +#endif Perl_va_copy(ap, apc); # ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, apc); @@ -5325,7 +5330,6 @@ S_gv_has_usable_name(pTHX_ GV *gv) void Perl_get_db_sub(pTHX_ SV **svp, CV *cv) { - dVAR; SV * const dbsv = GvSVn(PL_DBsub); const bool save_taint = TAINT_get; @@ -5385,19 +5389,17 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) } int -Perl_my_dirfd(pTHX_ DIR * dir) { +Perl_my_dirfd(DIR * dir) { /* Most dirfd implementations have problems when passed NULL. */ if(!dir) return -1; #ifdef HAS_DIRFD - PERL_UNUSED_CONTEXT; return dirfd(dir); #elif defined(HAS_DIR_DD_FD) - PERL_UNUSED_CONTEXT; return dir->dd_fd; #else - Perl_die(aTHX_ PL_no_func, "dirfd"); + Perl_croak_nocontext(PL_no_func, "dirfd"); assert(0); /* NOT REACHED */ return 0; #endif diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index 911f341..6ec85c0 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]perl5211delta.pod +PERLDELTA_CURRENT = [.pod]perl5212delta.pod $(PERLDELTA_CURRENT) : [.pod]perldelta.pod Copy/NoConfirm/Log $(MMS$SOURCE) $(PERLDELTA_CURRENT) diff --git a/warnings.h b/warnings.h index 5bbb691..21c6d83 100644 --- a/warnings.h +++ b/warnings.h @@ -105,6 +105,8 @@ /* Warnings Categories added in Perl 5.021 */ #define WARN_EXPERIMENTAL__WIN32_PERLIO 60 +#define WARN_MISSING 61 +#define WARN_REDUNDANT 62 #define WARNsize 16 #define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125" diff --git a/win32/Makefile b/win32/Makefile index 383bee7..3b0c701 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -37,7 +37,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.21.1 +#INST_VER = \5.21.2 # # Comment this out if you DON'T want your perl installation to have @@ -1155,7 +1155,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\perl5211delta.pod + copy ..\pod\perldelta.pod ..\pod\perl5212delta.pod cd ..\win32 $(PERLEXE) $(PL2BAT) $(UTILS) $(MINIPERL) -I..\lib ..\autodoc.pl .. @@ -1250,7 +1250,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 \ - perl5211delta.pod perlaix.pod perlamiga.pod perlandroid.pod \ + perl5212delta.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.mk b/win32/makefile.mk index b0f54d7..d376a8c 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -43,7 +43,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.21.1 +#INST_VER *= \5.21.2 # # Comment this out if you DON'T want your perl installation to have @@ -1349,7 +1349,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\perl5211delta.pod + copy ..\pod\perldelta.pod ..\pod\perl5212delta.pod $(PERLEXE) $(PL2BAT) $(UTILS) $(MINIPERL) -I..\lib ..\autodoc.pl .. $(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q .. @@ -1443,7 +1443,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 \ - perl5211delta.pod perlaix.pod perlamiga.pod perlandroid.pod \ + perl5212delta.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/pod.mak b/win32/pod.mak index 7e28c03..ed33b2e 100644 --- a/win32/pod.mak +++ b/win32/pod.mak @@ -38,6 +38,7 @@ POD = perl.pod \ perl5200delta.pod \ perl5210delta.pod \ perl5211delta.pod \ + perl5212delta.pod \ perl561delta.pod \ perl56delta.pod \ perl581delta.pod \ @@ -169,6 +170,7 @@ MAN = perl.man \ perl5200delta.man \ perl5210delta.man \ perl5211delta.man \ + perl5212delta.man \ perl561delta.man \ perl56delta.man \ perl581delta.man \ @@ -300,6 +302,7 @@ HTML = perl.html \ perl5200delta.html \ perl5210delta.html \ perl5211delta.html \ + perl5212delta.html \ perl561delta.html \ perl56delta.html \ perl581delta.html \ @@ -431,6 +434,7 @@ TEX = perl.tex \ perl5200delta.tex \ perl5210delta.tex \ perl5211delta.tex \ + perl5212delta.tex \ perl561delta.tex \ perl56delta.tex \ perl581delta.tex \