DH <crazyinsomniac@yahoo.com>
Diab Jerius <dj@head-cfa.harvard.edu>
dLux <dlux@spam.sch.bme.hu>
+Dmitri Tikhonov <dmitri@cpan.org>
Dmitry Karasik <dk@tetsuo.karasik.eu.org>
Dominic Dunlop <domo@computer.org>
Dominic Hargreaves <dom@earth.li>
d_pthread_yield=''
d_sched_yield=''
sched_yield=''
+d_ptrdiff_t=''
d_qgcvt=''
d_random_r=''
random_r_proto=''
i_poll=''
i_prot=''
i_pthread=''
-d_ptrdiff_t=''
d_pwage=''
d_pwchange=''
d_pwclass=''
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" ;;
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
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) {
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! */
}
set d_off64_t
eval $setvar
-: check for ptrdiff_t
-echo " "
-echo "Checking to see if you have ptrdiff_t..." >&4
-$cat >try.c <<EOCP
-#include <stddef.h>
-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 " "
esac
$rm_try
+: check for ptrdiff_t
+echo " "
+echo "Checking to see if you have ptrdiff_t..." >&4
+$cat >try.c <<EOCP
+#include <stddef.h>
+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
#include <db.h>
#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;
#include <db.h>
#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;
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 <<EOSH >>Cppsym.know
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
$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 }
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
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"
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=''
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'
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=''
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'
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'
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'
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='1'
+subversion='2'
sysman='/usr/share/man/man1'
tail=''
tar=''
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'
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
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=''
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'
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=''
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'
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'
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'
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='1'
+subversion='2'
sysman='/usr/share/man/man1'
tail=''
tar=''
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'
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
=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
=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.
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.
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 5.21.1 may not be binary compatible with Perl 5.21.0 or
+B<Perl 5.21.2 may not be binary compatible with Perl 5.21.1 or
earlier Perl releases.> 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.)
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.
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
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
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
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
"url" : "http://perl5.git.perl.org/"
}
},
- "version" : "5.021001"
+ "version" : "5.021002"
}
homepage: http://www.perl.org/
license: http://dev.perl.org/licenses/
repository: http://perl5.git.perl.org/
-version: '5.021001'
+version: '5.021002'
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
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`
# 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 <<EOF
-cd utils; $(LDLIBPTH) $(MAKE) clean
-rm -f lib/Config_git.pl git_version.h
-@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \
- $(MINIPERL) make_ext.pl --target=clean $$x MAKE=$(MAKE) ; \
+ $(MINIPERL) make_ext.pl --target=clean $$x MAKE="$(MAKE)" ; \
done
_cleaner1:
-cd utils; $(LDLIBPTH) $(MAKE) $(CLEAN)
-@if test -f $(MINIPERL_EXE) ; then \
for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \
- $(MINIPERL) make_ext.pl --target=$(CLEAN) $$x MAKE=$(MAKE) ; \
+ $(MINIPERL) make_ext.pl --target=$(CLEAN) $$x MAKE="$(MAKE)" ; \
done ; \
else \
sh $(CLEAN).sh ; \
$spitshell >>$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 \
$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!
# 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
# 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
* 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:
* 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,
* 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:
* 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 "" /**/
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.
},
'experimental' => {
- 'DISTRIBUTION' => 'LEONT/experimental-0.007.tar.gz',
+ 'DISTRIBUTION' => 'LEONT/experimental-0.008.tar.gz',
'FILES' => q[cpan/experimental],
'EXCLUDED' => [
qr{^t/release-.*\.t},
},
'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' => {
},
'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/},
},
'Module::CoreList' => {
- 'DISTRIBUTION' => 'BINGOS/Module-CoreList-3.11.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.021001.tar.gz',
'FILES' => q[dist/Module-CoreList],
},
},
'Pod::Usage' => {
- 'DISTRIBUTION' => 'MAREKR/Pod-Usage-1.63.tar.gz',
+ 'DISTRIBUTION' => 'MAREKR/Pod-Usage-1.64.tar.gz',
'FILES' => q[cpan/Pod-Usage],
},
},
'Storable' => {
- 'DISTRIBUTION' => 'AMS/Storable-2.45.tar.gz',
+ 'DISTRIBUTION' => 'AMS/Storable-2.51.tar.gz',
'FILES' => q[dist/Storable],
},
pp_ctl.c
);
my @SKIP_DIRS = qw(
+ dist
ext
lib
pod
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;
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=''
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=''
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'
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'
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'
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'
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'
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='1'
+subversion='2'
sysman='/usr/share/man/man1'
sysroot=''
tail=''
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'
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.
* 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.
* 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
* 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.
* 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:
* 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
};
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 = (
=head1 EPIGRAPHS
+=head2 v5.21.1 - Robert Jordan, The Crossroads of Twilights, Book 10 of the Wheel of Time
+
+L<Announced on 2014-06-20 by Matthew Horsfall|http://www.nntp.perl.org/group/perl.perl5.porters/2014/06/msg217030.html>
+
+ 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<Announced on 2014-05-27 by Ricardo Signes|http://www.nntp.perl.org/group/perl.perl5.porters/2014/05/msg215826.html>
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 $!;
XXX Generate this with:
- perl Porting/acknowledgements.pl v5.21.1..HEAD
+ perl Porting/acknowledgements.pl v5.21.2..HEAD
=head1 Reporting Bugs
The line in F<INSTALL> 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<pod/perlpolicy.pod>.
+
When doing a BLEAD-POINT or BLEAD-FINAL release, also make sure the
C<PERL_API_*> constants in F<patchlevel.h> are in sync with the version
you're releasing, unless you're absolutely sure the release you're about to
=head4 Update C<%Module::CoreList::released> and C<CAVEATS>
-In addition, if this is a final release (rather than a release candidate):
+For any release except an RC:
=over 4
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<THE KEEPERS OF THE PUMPKIN>.
+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<THE KEEPERS OF THE PUMPKIN>.
I<If you're making a BLEAD-FINAL release>, also update the "SELECTED
RELEASE SIZES" section with the output of
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
$ ./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:
$ 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
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
=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
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?
Note, of course, that this will only tell whether B<your> 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<struct gp> and C<struct magic> are both currently allocated by C<malloc>.
=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
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
=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
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
=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',
=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<PERLLIB_PREFIX>), you
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.
#
# 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;
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;
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";;
}
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";;
void
Perl_av_reify(pTHX_ AV *av)
{
- dVAR;
SSize_t key;
PERL_ARGS_ASSERT_AV_REIFY;
void
Perl_av_extend(pTHX_ AV *av, SSize_t key)
{
- dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_AV_EXTEND;
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) {
SV**
Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval)
{
- dVAR;
-
PERL_ARGS_ASSERT_AV_FETCH;
assert(SvTYPE(av) == SVt_PVAV);
SV**
Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
{
- dVAR;
SV** ary;
PERL_ARGS_ASSERT_AV_STORE;
void
Perl_av_clear(pTHX_ AV *av)
{
- dVAR;
SSize_t extra;
bool real;
void
Perl_av_push(pTHX_ AV *av, SV *val)
{
- dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_AV_PUSH;
SV *
Perl_av_pop(pTHX_ AV *av)
{
- dVAR;
SV *retval;
MAGIC* mg;
void
Perl_av_unshift(pTHX_ AV *av, SSize_t num)
{
- dVAR;
SSize_t i;
MAGIC* mg;
SV *
Perl_av_shift(pTHX_ AV *av)
{
- dVAR;
SV *retval;
MAGIC* mg;
void
Perl_av_fill(pTHX_ AV *av, SSize_t fill)
{
- dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_AV_FILL;
SV *
Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags)
{
- dVAR;
SV *sv;
PERL_ARGS_ASSERT_AV_DELETE;
bool
Perl_av_exists(pTHX_ AV *av, SSize_t key)
{
- dVAR;
PERL_ARGS_ASSERT_AV_EXISTS;
assert(SvTYPE(av) == SVt_PVAV);
static MAGIC *
S_get_aux_mg(pTHX_ AV *av) {
- dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_GET_AUX_MG;
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);
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 <stdlib.h>
# (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?
*-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"
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
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
;;
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=''
#$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 <execinfo.h> 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.
#$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 <dlfcn.h> 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.
#$d_dirnamlen DIRNAMLEN /**/
#define Direntry_t $direntrytype
+/* I_EXECINFO:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <execinfo.h> for backtrace() support.
+ */
+#$i_execinfo I_EXECINFO /**/
+
/* I_GRP:
* This symbol, if defined, indicates to the C program that it should
* include <grp.h>.
*/
#$i_sysuio I_SYSUIO /**/
+/* I_TERMIO:
+ * This symbol, if defined, indicates that the program should include
+ * <termio.h> rather than <sgtty.h>. 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
+ * <sgtty.h> rather than <termio.h>. 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 <time.h>.
#$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 <execinfo.h> 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 <execinfo.h> 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 <execinfo.h> for backtrace() support.
- */
-#$i_execinfo I_EXECINFO /**/
-
-/* I_TERMIO:
- * This symbol, if defined, indicates that the program should include
- * <termio.h> rather than <sgtty.h>. 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
- * <sgtty.h> rather than <termio.h>. 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.
*/
*/
#$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.
*/
#$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 <sys/uio.h>
# 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';
}
+++ /dev/null
-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;
+++ /dev/null
-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.
-
+++ /dev/null
-This software is copyright (c) 2014 by Paul Evans <leonerd@leonerd.org.uk>.
-
-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 <leonerd@leonerd.org.uk>.
-
-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.
-
- <one line to give the program's name and a brief idea of what it does.>
- Copyright (C) 19yy <name of author>
-
- 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.
-
- <signature of Ty Coon>, 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 <leonerd@leonerd.org.uk>.
-
-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
-
+++ /dev/null
-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
+++ /dev/null
-{
- "abstract" : "Family-neutral IP socket supporting both IPv4 and IPv6",
- "author" : [
- "Paul Evans <leonerd@leonerd.org.uk>"
- ],
- "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"
-}
+++ /dev/null
----
-abstract: 'Family-neutral IP socket supporting both IPv4 and IPv6'
-author:
- - 'Paul Evans <leonerd@leonerd.org.uk>'
-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'
+++ /dev/null
-# 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' => {}
-)
-;
+++ /dev/null
-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 <leonerd@leonerd.org.uk>
-
# $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;
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;
}
# (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;
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,
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;
=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
ability of B<pod2usage()> 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);
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<there's more than one way to do it>, and
B<pod2usage()> adheres to this philosophy. If you are interested in
seeing a number of different ways to invoke B<pod2usage> (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<pod2usage>.
+
+
=head1 EXAMPLES
Each of the following invocations of C<pod2usage()> will print just the
uses B<Pod::Usage> in combination with B<Getopt::Long> 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;
## 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
=head1 OPTIONS
- =over 8
+ =over 4
=item B<-help>
package experimental;
-$experimental::VERSION = '0.007';
+$experimental::VERSION = '0.008';
use strict;
use warnings;
+use version ();
use feature ();
use Carp qw/croak carp/;
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 = (
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";
}
}
=head1 VERSION
-version 0.007
+version 0.008
=head1 SYNOPSIS
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
Perl_debstack(pTHX)
{
#ifndef SKIP_DEBUGGING
- dVAR;
if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
return 0;
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;
}
\.tmp$
\.#
\.rej$
+\..*\.sw.?$
# Avoid OS-specific files/dirs
# Mac OSX metadata
\bcover_db\b
\bcovered\b
+# Avoid prove files
+\B\.prove$
+
# Avoid MYMETA files
^MYMETA\.
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;
$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
use vars qw{ $VERSION @EXPORT };
-$VERSION = '0.91';
+$VERSION = '0.92';
use Filter::Util::Call;
use Carp;
}
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;
use strict;
use warnings;
-our $VERSION = "1.32";
+our $VERSION = "1.33";
XSLoader::load 'IO', $VERSION;
sub import {
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;
eval { kill 0 * $unsafe };
SKIP: {
skip($^O) if $^O eq 'MSWin32' or $^O eq 'NetWare';
- like($@, '^Insecure');
+ like($@, qr/^Insecure/);
}
$x->close;
ok(!$?); # Calling the method worked
chop($unsafe = <$x>);
eval { kill 0 * $unsafe };
-unlike($@,'^Insecure');
+unlike($@,qr/^Insecure/);
$x->close;
TODO: {
# _a : accuracy
# _p : precision
-$VERSION = '1.9994';
+$VERSION = '1.9996';
require 5.006002;
require Exporter;
my $class = "Math::BigInt";
use 5.006002;
-$VERSION = '1.9995';
+$VERSION = '1.9996';
@ISA = qw(Exporter);
@EXPORT_OK = qw(objectify bgcd blcm);
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;
}
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
# use warnings; # do not use warnings for older Perls
use vars qw/$VERSION/;
-$VERSION = '1.9994';
+$VERSION = '1.9996';
package Math::BigInt;
+5.021002
+ - Prepared for v5.21.2
+
5.021001_01
- Prepared for v5.21.1
%bug_tracker %deprecated %delta/;
use Module::CoreList::TieHashDelta;
use version;
-$VERSION = '5.021001_01';
+$VERSION = '5.021002';
my $dumpinc = 0;
sub import {
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 ) {
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
removed => {
}
},
+ 5.021002 => {
+ delta_from => 5.021001,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
for my $version (sort { $a <=> $b } keys %deprecated) {
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
use strict;
use vars qw($VERSION);
-$VERSION = '5.021001_01';
+$VERSION = '5.021002';
sub TIEHASH {
my ($class, $changed, $removed, $parent) = @_;
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 '';
}
use Module::CoreList;
use Module::CoreList::TieHashDelta;
-$VERSION = '5.021001_01';
+$VERSION = '5.021002';
sub utilities {
my $perl = shift;
's2p' => 1,
}
},
+ 5.021002 => {
+ delta_from => 5.021001,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
for my $version (sort { $a <=> $b } keys %delta) {
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-$VERSION = '3.48';
+$VERSION = '3.49';
my $xs_version = $VERSION;
$VERSION =~ tr/_//;
# 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);
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = '3.48';
+$VERSION = '3.49';
$VERSION =~ tr/_//;
my %module = (MacOS => 'Mac',
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.48';
+$VERSION = '3.49';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use strict;
use vars qw($VERSION @ISA);
-$VERSION = '3.48';
+$VERSION = '3.49';
$VERSION =~ tr/_//;
require File::Spec::Unix;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-$VERSION = '3.48';
+$VERSION = '3.49';
$VERSION =~ tr/_//;
require Exporter;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.48';
+$VERSION = '3.49';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.48';
+$VERSION = '3.49';
$VERSION =~ tr/_//;
@ISA = qw(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);
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.48';
+$VERSION = '3.49';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.48';
+$VERSION = '3.49';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
- [perl #121928] Fix memory leak for dclone inside freeze hook
- (Alex Solovey)
+Wed Jul 2 16:25:25 IST 2014 Abhijit Menon-Sen <ams@toroid.org>
+ 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 <ams@toroid.org>
Version 2.45
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' );
}
use strict;
use warnings;
-our $VERSION = '1.94';
+our $VERSION = '1.95';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
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
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);' .
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;' .
/* 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;
/* MAGIC (in mg.h sense) hooks */
-int
+STATIC int
ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
{
ithread *thread = (ithread *)mg->mg_ptr;
return (0);
}
-int
+STATIC int
ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
{
ithread *thread = (ithread *)mg->mg_ptr;
return (0);
}
-int
+STATIC int
ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
{
PERL_UNUSED_ARG(param);
return (0);
}
-MGVTBL ithread_vtbl = {
+STATIC const MGVTBL ithread_vtbl = {
ithread_mg_get, /* get */
0, /* set */
0, /* len */
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;
Perl_do_open_raw(pTHX_ GV *gv, const char *oname, STRLEN len,
int rawmode, int rawperm)
{
- dVAR;
PerlIO *saveifp;
PerlIO *saveofp;
int savefd;
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;
PerlIO *
Perl_nextargv(pTHX_ GV *gv)
{
- dVAR;
IO * const io = GvIOp(gv);
PERL_ARGS_ASSERT_NEXTARGV;
bool
Perl_do_close(pTHX_ GV *gv, bool not_implicit)
{
- dVAR;
bool retval;
IO *io;
bool
Perl_io_close(pTHX_ IO *io, bool not_implicit)
{
- dVAR;
bool retval = FALSE;
PERL_ARGS_ASSERT_IO_CLOSE;
bool
Perl_do_eof(pTHX_ GV *gv)
{
- dVAR;
IO * const io = GvIO(gv);
PERL_ARGS_ASSERT_DO_EOF;
Off_t
Perl_do_tell(pTHX_ GV *gv)
{
- dVAR;
IO *const io = GvIO(gv);
PerlIO *fp;
bool
Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
{
- dVAR;
IO *const io = GvIO(gv);
PerlIO *fp;
Off_t
Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
{
- dVAR;
IO *const io = GvIO(gv);
PerlIO *fp;
bool
Perl_do_print(pTHX_ SV *sv, PerlIO *fp)
{
- dVAR;
-
PERL_ARGS_ASSERT_DO_PRINT;
/* assuming fp is checked earlier */
I32
Perl_my_stat_flags(pTHX_ const U32 flags)
{
- dVAR;
dSP;
IO *io;
GV* gv;
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;
void
Perl_do_execfree(pTHX)
{
- dVAR;
Safefree(PL_Argv);
PL_Argv = NULL;
Safefree(PL_Cmd);
I32
Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
{
- dVAR;
I32 val;
I32 tot = 0;
const char *const what = PL_op_name[type];
* is in the list of groups returned from getgroups().
*/
{
- dVAR;
-
PERL_ARGS_ASSERT_CANDO;
PERL_UNUSED_CONTEXT;
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;
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);
I32
Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
{
- dVAR;
char *a;
I32 ret = -1;
const I32 id = SvIVx(*++mark);
I32
Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
{
- dVAR;
#ifdef HAS_MSG
STRLEN len;
const I32 id = SvIVx(*++mark);
Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
{
#ifdef HAS_MSG
- dVAR;
char *mbuf;
long mtype;
I32 msize, flags, ret;
Perl_do_semop(pTHX_ SV **mark, SV **sp)
{
#ifdef HAS_SEM
- dVAR;
STRLEN opsize;
const I32 id = SvIVx(*++mark);
SV * const opstr = *++mark;
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);
PerlIO *
Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
{
- dVAR;
SV * const tmpcmd = newSV(0);
PerlIO *fp;
STRLEN len;
STATIC I32
S_do_trans_simple(pTHX_ SV * const sv)
{
- dVAR;
I32 matches = 0;
STRLEN len;
U8 *s = (U8*)SvPV_nomg(sv,len);
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;
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;
STATIC I32
S_do_trans_simple_utf8(pTHX_ SV * const sv)
{
- dVAR;
U8 *s;
U8 *send;
U8 *d;
STATIC I32
S_do_trans_count_utf8(pTHX_ SV * const sv)
{
- dVAR;
const U8 *s;
const U8 *start = NULL;
const U8 *send;
STATIC I32
S_do_trans_complex_utf8(pTHX_ SV * const sv)
{
- dVAR;
U8 *start, *send;
U8 *d;
I32 matches = 0;
I32
Perl_do_trans(pTHX_ SV *sv)
{
- dVAR;
STRLEN len;
const I32 hasutf = (PL_op->op_private &
(OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
void
Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp)
{
- dVAR;
SV ** const oldmark = mark;
I32 items = sp - mark;
STRLEN len;
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;
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);
void
Perl_do_vecset(pTHX_ SV *sv)
{
- dVAR;
SSize_t offset, bitoffs = 0;
int size;
unsigned char *s;
void
Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
{
- dVAR;
#ifdef LIBERAL
long *dl;
long *ll;
OP *
Perl_do_kv(pTHX)
{
- dVAR;
dSP;
HV * const keys = MUTABLE_HV(POPs);
HE *entry;
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++ != '{')
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);
void
Perl_dump_all_perl(pTHX_ bool justperl)
{
-
- dVAR;
PerlIO_setlinebuf(Perl_debug_log);
if (PL_main_root)
op_dump(PL_main_root);
void
Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
{
- dVAR;
I32 i;
PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
void
Perl_dump_eval(pTHX)
{
- dVAR;
op_dump(PL_eval_root);
}
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 : ""); \
}
void
Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
{
- dVAR;
UV seq;
const OPCODE optype = o->op_type;
}
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");
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;
void
Perl_sv_dump(pTHX_ SV *sv)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_DUMP;
if (SvROK(sv))
int
Perl_runops_debug(pTHX)
{
- dVAR;
if (!PL_op) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
return 0;
I32
Perl_debop(pTHX_ const OP *o)
{
- dVAR;
int count;
PERL_ARGS_ASSERT_DEBOP;
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;
void
Perl_watch(pTHX_ char **addr)
{
- dVAR;
-
PERL_ARGS_ASSERT_WATCH;
PL_watchaddr = addr;
STATIC void
S_debprof(pTHX_ const OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_DEBPROF;
if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
void
Perl_debprofdump(pTHX)
{
- dVAR;
unsigned i;
if (!PL_profiledata)
return;
|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
|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
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
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
#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.
|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
|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 \
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
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
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
#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
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
#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)
#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)
#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)
#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)
#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)
#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)
#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)
#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)
#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)
#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)
#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)
#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
# 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.
=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").
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);
}
}
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);
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*/
{ 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
};
B::OP::savefree = 48
B::OP::static = 49
B::OP::folded = 50
+ B::OP::lastsib = 51
+ B::OP::parent = 52
PREINIT:
SV *ret;
PPCODE:
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
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 */
: 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));
}
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 {
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();
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, '\*<none>::', 'glob(q{.})';
+like $out, qr/\*<none>::/, 'glob(q{.})';
# Test op_other in -debug
$out = runperl(
$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;
$end =~ s/<NEXT>/$next/;
-like $out, $end, 'OP_AND->op_other points correctly';
+like $out, qr/$end/, 'OP_AND->op_other points correctly';
__END__
package Devel::Peek;
-$VERSION = '1.17';
+$VERSION = '1.18';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
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);
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 ||
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;
}
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
FLAGS = \(IOK,pIOK\)
IV = 2
HASH
+
$_ = "hello";
do_test('rvalue substr', 'substr $_, 1, 2', <<'SUBSTR', '', '', 1);
SV = PV\($ADDR\) at $ADDR
{
1 TYPE = leave ===> NULL
TARG = 1
- FLAGS = (VOID,KIDS,PARENS,SLABBED)
+ FLAGS = (VOID,KIDS,PARENS,SLABBED,LASTSIB)
PRIVATE = (REFCOUNTED)
REFCNT = 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)
{
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
}
}
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);
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)) {
* 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)) {
hash_traversal_mask
);
-our $VERSION = '0.17';
+our $VERSION = '0.18';
require XSLoader;
XSLoader::load();
use Carp;
use Symbol qw(gensym qualify);
-$VERSION = '1.16';
+$VERSION = '1.17';
@ISA = qw(Exporter);
@EXPORT = qw(open3);
# A tie in the parent should not be allowed to cause problems.
untie *STDIN;
untie *STDOUT;
+ untie *STDERR;
close $stat_r;
require Fcntl;
}
use strict;
-use Test::More tests => 38;
+use Test::More tests => 44;
use IO::Handle;
use IPC::Open3;
}
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;
+ }
+}
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
our ($AUTOLOAD, %SIGRT);
-our $VERSION = '1.40';
+our $VERSION = '1.41';
require XSLoader;
use warnings;
use Carp;
-our $VERSION = '0.61';
+our $VERSION = '0.62';
require XSLoader;
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;
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);
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 {
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;
}
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;
}
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;
}
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;
}
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));
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("$"));
}
#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);
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':
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);
}
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;
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);
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__)
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"]});
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)));
}
else {
is($warn_msg, undef, "$desc - __WARN__ not called");
- unlike($@, 'pre-err', "$desc - \$@ modified");
+ unlike($@, qr/pre-err/, "$desc - \$@ modified");
}
like($@,
(
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';
}
}
+# 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();
package arybase;
-our $VERSION = "0.07";
+our $VERSION = "0.08";
require XSLoader;
XSLoader::load(); # This returns true, which makes require happy.
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);
}
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;
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;
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);
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;
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));
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))
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;
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;
GV*
Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
{
- dVAR;
GV* gv;
CV* cv;
HV* varstash;
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;
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;
void
Perl_gv_check(pTHX_ HV *stash)
{
- dVAR;
I32 i;
PERL_ARGS_ASSERT_GV_CHECK;
GV *
Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
{
- dVAR;
PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
assert(!(flags & ~SVf_UTF8));
GP*
Perl_gp_ref(pTHX_ GP *gp)
{
- dVAR;
if (!gp)
return NULL;
gp->gp_refcnt++;
void
Perl_gp_free(pTHX_ GV *gv)
{
- dVAR;
GP* gp;
int attempts = 100;
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);
CV*
Perl_gv_handler(pTHX_ HV *stash, I32 id)
{
- dVAR;
MAGIC *mg;
AMT *amtp;
U32 newgen;
bool
Perl_try_amagic_un(pTHX_ int method, int flags) {
- dVAR;
dSP;
SV* tmpsv;
SV* const arg = TOPs;
bool
Perl_try_amagic_bin(pTHX_ int method, int flags) {
- dVAR;
dSP;
SV* const left = TOPm1s;
SV* const right = TOPs;
# 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
STATIC HE*
S_new_he(pTHX)
{
- dVAR;
HE* he;
void ** const root = &PL_body_roots[HE_SVSLOT];
void
Perl_free_tied_hv_pool(pTHX)
{
- dVAR;
HE *he = PL_hv_fetch_ent_mh;
while (he) {
HE * const ohe = he;
bool is_utf8;
int masked_flags;
const int return_svp = action & HV_FETCH_JUST_SV;
+ HEK *keysv_hek = NULL;
if (!hv)
return NULL;
}
}
- 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);
{
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
}
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)
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;
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);
return sv;
}
+
+ not_found:
if (SvREADONLY(hv)) {
hv_notallowed(k_flags, key, klen,
"Attempt to delete disallowed key '%"SVf"' from"
STATIC void
S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
{
- dVAR;
STRLEN i = 0;
char *a = (char*) HvARRAY(hv);
HE **aep;
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;
STATIC SV*
S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry)
{
- dVAR;
SV *val;
PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
void
Perl_hv_free_ent(pTHX_ HV *hv, HE *entry)
{
- dVAR;
SV *val;
PERL_ARGS_ASSERT_HV_FREE_ENT;
void
Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry)
{
- dVAR;
-
PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
if (!entry)
void
Perl_hv_clear_placeholders(pTHX_ HV *hv)
{
- dVAR;
const U32 items = (U32)HvPLACEHOLDERS_get(hv);
PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
void
Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
{
- dVAR;
XPVHV* xhv;
bool save;
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;
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);
}
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;
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);
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;
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;
}
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;
void
Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
+#ifdef USE_ITHREADS
dVAR;
+#endif
PERL_UNUSED_CONTEXT;
while (he) {
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;
/* 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)
Perl_croak_nocontext("%s",PL_memory_wrap);
}
#ifdef GCC_DIAG_PRAGMA
-GCC_DIAG_RESTORE;
+GCC_DIAG_RESTORE /* Intentionally left semicolonless. */
#endif
/* ------------------------------- utf8.h ------------------------------- */
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
/* 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. */
I32
Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
{
- dVAR;
-
PERL_ARGS_ASSERT_KEYWORD;
switch (len)
}
/* Generated from:
- * 7c6d47fd2890b2422a40331ec90eac08f9808209b01f2b9c113141410fea91b5 regen/keywords.pl
+ * 963511f90d23994583c88b07c3cf2258473567702972e94b59a635727c4aa944 regen/keywords.pl
* ex: set ro: */
#define KEY_y 254
/* Generated from:
- * 7c6d47fd2890b2422a40331ec90eac08f9808209b01f2b9c113141410fea91b5 regen/keywords.pl
+ * 963511f90d23994583c88b07c3cf2258473567702972e94b59a635727c4aa944 regen/keywords.pl
* ex: set ro: */
sub cp;
sub mv;
-$VERSION = '2.29';
+$VERSION = '2.30';
require Exporter;
@ISA = qw(Exporter);
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<copy> 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
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';
"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';
'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
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;
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";
$na = 0;
$na = eval { ~$aI };
-like($@, '');
+is($@, '');
bless \$x, OscalarI;
{
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;
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.
|
+- misc
|
+ +- missing
+ |
+- numeric
|
+- once
|
+- redefine
|
+ +- redundant
+ |
+- regexp
|
+- severe --------+
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<warning, fatal>
# 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]
'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]
'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]
);
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]
'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]
'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]
$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 ;
Perl_set_numeric_radix(pTHX)
{
#ifdef USE_LOCALE_NUMERIC
- dVAR;
# ifdef HAS_LOCALECONV
const struct lconv* const lc = localeconv();
#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)
{
* POSIX::setlocale() */
char *save_newnum;
- dVAR;
if (! newnum) {
Safefree(PL_numeric_name);
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
set_numeric_radix();
+#else
+ PERL_UNUSED_ARG(newnum);
#endif /* USE_LOCALE_NUMERIC */
}
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"));
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));
* should be called directly only from this file and from
* POSIX::setlocale() */
- dVAR;
-
if (! newcoll) {
if (PL_collation_name) {
++PL_collation_ix;
++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'). */
}
}
+#else
+ PERL_UNUSED_ARG(newcoll);
#endif /* USE_LOCALE_COLLATE */
}
int ok = 1;
#if defined(USE_LOCALE)
- dVAR;
-
#ifdef USE_LOCALE_CTYPE
char *curctype = NULL;
#endif /* USE_LOCALE_CTYPE */
Safefree(curnum);
#endif /* USE_LOCALE_NUMERIC */
+#else /* !USE_LOCALE */
+ PERL_UNUSED_ARG(printwarn);
#endif /* USE_LOCALE */
return ok;
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 */
/* 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;
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));
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
# 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) {
Safefree(save_input_locale);
return is_utf8;
}
- Safefree(codeset);
}
# endif
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 */
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) {
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));
#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 */
# 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\-]+)=(.*)$/) {
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;
}
}
- print "\tMaking $mname ($target)\n";
+ print "\tMaking $mname ($target)\n" if $verbose;
build_extension($ext_pathname, $perl, $mname, $target,
[@pass_through, @{$extra_passthrough{$spec} || []}]);
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
}
# 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) {
}
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;
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
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;
int
Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...)
{
- dTHXs;
int ret = 0;
va_list(arglist);
void
Perl_save_long(pTHX_ long int *longp)
{
- dVAR;
-
PERL_ARGS_ASSERT_SAVE_LONG;
SSCHECK(3);
void
Perl_save_iv(pTHX_ IV *ivp)
{
- dVAR;
-
PERL_ARGS_ASSERT_SAVE_IV;
SSCHECK(3);
void
Perl_save_nogv(pTHX_ GV *gv)
{
- dVAR;
-
PERL_ARGS_ASSERT_SAVE_NOGV;
SSCHECK(2);
void
Perl_save_list(pTHX_ SV **sarg, I32 maxsarg)
{
- dVAR;
I32 i;
PERL_ARGS_ASSERT_SAVE_LIST;
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);
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();
}
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);
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);
bool
Perl_is_utf8_idcont(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_IDCONT;
return _is_utf8_idcont(p);
bool
Perl_is_utf8_xidcont(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_XIDCONT;
return _is_utf8_xidcont(p);
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
bool
Perl_is_utf8_alnumc(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_ALNUMC;
return isALPHANUMERIC_utf8(p);
bool
Perl_is_utf8_alpha(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_ALPHA;
return isALPHA_utf8(p);
bool
Perl_is_utf8_ascii(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_ASCII;
PERL_UNUSED_CONTEXT;
bool
Perl_is_utf8_blank(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_BLANK;
PERL_UNUSED_CONTEXT;
bool
Perl_is_utf8_space(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_SPACE;
PERL_UNUSED_CONTEXT;
bool
Perl_is_utf8_perl_space(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_PERL_SPACE;
PERL_UNUSED_CONTEXT;
bool
Perl_is_utf8_perl_word(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_PERL_WORD;
PERL_UNUSED_CONTEXT;
bool
Perl_is_utf8_digit(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_DIGIT;
return isDIGIT_utf8(p);
bool
Perl_is_utf8_posix_digit(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_POSIX_DIGIT;
PERL_UNUSED_CONTEXT;
bool
Perl_is_utf8_upper(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_UPPER;
return isUPPER_utf8(p);
bool
Perl_is_utf8_lower(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_LOWER;
return isLOWER_utf8(p);
bool
Perl_is_utf8_cntrl(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
PERL_UNUSED_CONTEXT;
bool
Perl_is_utf8_graph(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_GRAPH;
return isGRAPH_utf8(p);
bool
Perl_is_utf8_print(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_PRINT;
return isPRINT_utf8(p);
bool
Perl_is_utf8_punct(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_PUNCT;
return isPUNCT_utf8(p);
bool
Perl_is_utf8_xdigit(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
PERL_UNUSED_CONTEXT;
bool
Perl_is_utf8_mark(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_IS_UTF8_MARK;
return _is_utf8_mark(p);
STATIC void
S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
{
- dVAR;
MGS* mgs;
bool bumped = FALSE;
*/
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))) {
int
Perl_mg_get(pTHX_ SV *sv)
{
- dVAR;
const I32 mgs_ix = SSNEW(sizeof(MGS));
bool saved = FALSE;
bool have_new = 0;
int
Perl_mg_set(pTHX_ SV *sv)
{
- dVAR;
const I32 mgs_ix = SSNEW(sizeof(MGS));
MAGIC* mg;
MAGIC* nextmg;
U32
Perl_mg_length(pTHX_ SV *sv)
{
- dVAR;
MAGIC* mg;
STRLEN len;
}
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) {
*/
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);
}
/*
*/
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 *
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;
}
void
Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
{
- dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_MG_LOCALIZE;
U32
Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
PERL_UNUSED_ARG(sv);
PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
int
Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
-
PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
if (PL_curpm) {
int
Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
I32 paren;
const char *s = NULL;
REGEXP *rx;
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 = "";
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)
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);
int
Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
/* Are we fetching a signal entry? */
int i = (I16)mg->mg_private;
void
Perl_despatch_signals(pTHX)
{
- dVAR;
int sig;
PL_sig_pending = 0;
for (sig = 1; sig < SIG_SIZE; sig++) {
int
Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
PERL_ARGS_ASSERT_MAGIC_SETISA;
PERL_UNUSED_ARG(sv);
int
Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
HV* stash;
-
PERL_ARGS_ASSERT_MAGIC_CLEARISA;
/* Bail out if destruction is going on */
Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
U32 argc, ...)
{
- dVAR;
dSP;
SV* ret = NULL;
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;
STATIC int
S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
{
- dVAR;
SV* ret;
PERL_ARGS_ASSERT_MAGIC_METHPACK;
int
Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
MAGIC *tmg;
SV *val;
U32
Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
I32 retval = 0;
SV* retsv;
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);
int
Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
{
- dVAR;
SV* ret;
PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
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));
int
Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
SV **svp;
PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
int
Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
{
- dVAR;
AV * const obj = MUTABLE_AV(mg->mg_obj);
PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
int
Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
AV * const obj = MUTABLE_AV(mg->mg_obj);
PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
int
Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
-
PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_CONTEXT;
int
Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
-
PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
PERL_UNUSED_ARG(sv);
int
Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
SV* const lsv = LvTARG(sv);
MAGIC * const found = mg_find_mglob(lsv);
int
Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
SV* const lsv = LvTARG(sv);
SSize_t pos;
STRLEN len;
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);
int
Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
-
PERL_ARGS_ASSERT_MAGIC_GETTAINT;
PERL_UNUSED_ARG(sv);
#ifdef NO_TAINT_SUPPORT
int
Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
-
PERL_ARGS_ASSERT_MAGIC_SETTAINT;
PERL_UNUSED_ARG(sv);
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);
void
Perl_vivify_defelem(pTHX_ SV *sv)
{
- dVAR;
MAGIC *mg;
SV *value = NULL;
int
Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
const char *s;
I32 paren;
const REGEXP * rx;
const char *sigpv;
STRLEN siglen;
PERL_ARGS_ASSERT_WHICHSIG_SV;
- PERL_UNUSED_CONTEXT;
sigpv = SvPV_const(sigsv, siglen);
return whichsig_pvn(sigpv, siglen);
}
Perl_whichsig_pv(pTHX_ const char *sig)
{
PERL_ARGS_ASSERT_WHICHSIG_PV;
- PERL_UNUSED_CONTEXT;
return whichsig_pvn(sig, strlen(sig));
}
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;
static void
S_unwind_handler_stack(pTHX_ const void *p)
{
- dVAR;
PERL_UNUSED_ARG(p);
PL_savestack_ix -= 5; /* Unprotect save in progress. */
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);
int
Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
-
PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
PERL_UNUSED_ARG(sv);
void
Perl_mro_isa_changed_in(pTHX_ HV* stash)
{
- dVAR;
HV* isarev;
AV* linear_mro;
HE* iter;
void
Perl_boot_core_mro(pTHX)
{
- dVAR;
static const char file[] = __FILE__;
Perl_mro_register(aTHX_ &dfs_alg);
XS(XS_mro_method_changed_in)
{
- dVAR;
dXSARGS;
SV* classname;
HV* class_stash;
#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) {
}
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) {
}
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) {
}
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) {
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;
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)) {
}
/*
-=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
absolute value). IS_NUMBER_IN_UV is not set if e notation was used or the
number is larger than a UV.
+C<flags> allows only C<PERL_SCAN_TRAILING>, which allows for trailing
+non-numeric text on an otherwise successful I<grok>, setting
+C<IS_NUMBER_TRAILING> 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;
int sawinf = 0;
int sawnan = 0;
- PERL_ARGS_ASSERT_GROK_NUMBER;
+ PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS;
while (s < send && isSPACE(*s))
s++;
} 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++;
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))
*valuep = 0;
return IS_NUMBER_IN_UV;
}
+ else if (flags & PERL_SCAN_TRAILING) {
+ return numtype | IS_NUMBER_TRAILING;
+ }
+
return 0;
}
{
NV x = 0.0;
#ifdef USE_LOCALE_NUMERIC
- dVAR;
-
PERL_ARGS_ASSERT_MY_ATOF;
{
void *
Perl_Slab_Alloc(pTHX_ size_t sz)
{
- dVAR;
OPSLAB *slab;
OPSLAB *slab2;
OPSLOT *slot;
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
*too = o->op_next;
Zero(o, opsz, I32 *);
o->op_slabbed = 1;
- return (void *)o;
+ goto gotit;
}
}
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;
}
void
Perl_Slab_Free(pTHX_ void *op)
{
- dVAR;
OP * const o = (OP *)op;
OPSLAB *slab;
void
Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
{
- dVAR;
const bool havepad = !!PL_comppad;
PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
if (havepad) {
void
Perl_opslab_free(pTHX_ OPSLAB *slab)
{
- dVAR;
OPSLAB *slab2;
PERL_ARGS_ASSERT_OPSLAB_FREE;
PERL_UNUSED_CONTEXT;
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);
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
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);
}
}
forget_pmop((PMOP*)kid);
}
find_and_forget_pmops(kid);
- kid = kid->op_sibling;
+ kid = OP_SIBLING(kid);
}
}
}
void
Perl_op_refcnt_lock(pTHX)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
PERL_UNUSED_CONTEXT;
OP_REFCNT_LOCK;
}
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 */
/*
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;
{
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;
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
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:
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);
OP *
Perl_scalar(pTHX_ OP *o)
{
- dVAR;
OP *kid;
/* assumes no premature commitment */
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 */
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;
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
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);
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;
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;
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:
{
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;
OP *
Perl_list(pTHX_ OP *o)
{
- dVAR;
OP *kid;
/* assumes no premature commitment */
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:
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
static OP *
S_scalarseq(pTHX_ OP *o)
{
- dVAR;
if (o) {
const OPCODE type = o->op_type;
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);
}
}
{
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;
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:
/* 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))
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;
&& (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;
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);
}
}
(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 */
}
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;
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:
/* 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 )
|| !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;
}
{
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;
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:
STATIC OP *
S_dup_attrlist(pTHX_ OP *o)
{
- dVAR;
OP *rop;
PERL_ARGS_ASSERT_DUP_ATTRLIST;
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,
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;
STATIC void
S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
{
- dVAR;
OP *pack, *imop, *arg;
SV *meth, *stashsv, **svp;
*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)) {
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;
}
}
}
/* 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;
}
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;
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) {
OP *
Perl_my_attrs(pTHX_ OP *o, OP *attrs)
{
- dVAR;
OP *rops;
int maybe_scalar = 0;
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);
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);
{
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);
}
int
Perl_block_start(pTHX_ int full)
{
- dVAR;
const int retval = PL_savestack_ix;
pad_block_start(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;
*/
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);
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));
void
Perl_newPROG(pTHX_ OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_NEWPROG;
if (PL_in_eval) {
OP *
Perl_localize(pTHX_ OP *o, I32 lex)
{
- dVAR;
-
PERL_ARGS_ASSERT_LOCALIZE;
if (o->op_flags & OPf_PARENS)
#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);
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;
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;
}
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);
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;
}
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;
}
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);
}
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;
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;
}
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)));
}
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;
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;
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;
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));
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);
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/(?{..})/ */
/* 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;
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);
OP *
Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
{
- dVAR;
-
PERL_ARGS_ASSERT_NEWGVOP;
#ifdef USE_ITHREADS
void
Perl_package(pTHX_ OP *o)
{
- dVAR;
SV *const sv = cSVOPo->op_sv;
PERL_ARGS_ASSERT_PACKAGE;
void
Perl_package_version( pTHX_ OP *v )
{
- dVAR;
U32 savehints = PL_hints;
PERL_ARGS_ASSERT_PACKAGE_VERSION;
PL_hints &= ~HINT_STRICT_VARS;
void
Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
{
- dVAR;
OP *pack;
OP *imop;
OP *veop;
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);
OP *
Perl_dofile(pTHX_ OP *term, I32 force_builtin)
{
- dVAR;
OP *doop;
GV *gv;
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
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;
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);
OP *
Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
{
- dVAR;
OP *o;
if (optype) {
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))
/* Other ops in the list. */
maybe_common_vars = TRUE;
}
- lop = lop->op_sibling;
+ lop = OP_SIBLING(lop);
}
}
else if ((left->op_private & OPpLVAL_INTRO)
#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;
OP *
Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
{
- dVAR;
-
PERL_ARGS_ASSERT_NEWLOGOP;
return new_logop(type, flags, &first, &other);
case OP_ENTER:
case OP_NULL:
case OP_NEXTSTATE:
- kid = kid->op_sibling;
+ kid = OP_SIBLING(kid);
break;
default:
if (kid != cLISTOPo->op_last)
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
&& ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> 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)
{
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);
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 */
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;
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);
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 &&
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)
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)
}
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 &&
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;
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,
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;
}
OP*
Perl_newLOOPEX(pTHX_ I32 type, OP *label)
{
- dVAR;
OP *o = NULL;
PERL_ARGS_ASSERT_NEWLOOPEX;
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;
STATIC bool
S_looks_like_bool(pTHX_ const OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
switch(o->op_type) {
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:
OP *
Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
{
- dVAR;
PERL_ARGS_ASSERT_NEWGIVENOP;
return newGIVWHENOP(
ref_array_or_hash(cond),
=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))
}
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);
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;
CV *
Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
- dVAR;
CV **spot;
SV **svspot;
const char *ps;
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 */
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);
void
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
- dVAR;
CV *cv;
GV *gv;
{
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());
OP *
Perl_ck_bitop(pTHX_ OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_CK_BITOP;
o->op_private = (U8)(PL_hints & HINT_INTEGER);
|| 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) &&
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
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));
}
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 */
OP *
Perl_ck_eof(pTHX_ OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_CK_EOF;
if (o->op_flags & OPf_KIDS) {
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;
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;
/* 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)
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);
}
OP *
Perl_ck_exists(pTHX_ OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_CK_EXISTS;
o = ck_fun(o);
OP *
Perl_ck_fun(pTHX_ OP *o)
{
- dVAR;
const int type = o->op_type;
I32 oa = PL_opargs[type] >> OASHIFT;
}
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;
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? */
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]);
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:
{
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;
}
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;
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? */
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)))
/* 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
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)) {
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;
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;
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);
}
}
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) {
&& !(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
{
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 ||
)
)
&& (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
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;
}
}
OP *
Perl_ck_match(pTHX_ OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_CK_MATCH;
if (o->op_type != OP_QR && PL_compcv) {
OP *
Perl_ck_open(pTHX_ OP *o)
{
- dVAR;
-
PERL_ARGS_ASSERT_CK_OPEN;
S_io_hints(aTHX_ 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);
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);
OP *
Perl_ck_require(pTHX_ OP *o)
{
- dVAR;
GV* gv;
PERL_ARGS_ASSERT_CK_REQUIRE;
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();
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);
}
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);
}
}
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;
OP *
Perl_ck_shift(pTHX_ OP *o)
{
- dVAR;
const I32 type = o->op_type;
PERL_ARGS_ASSERT_CK_SHIFT;
OP *
Perl_ck_sort(pTHX_ OP *o)
{
- dVAR;
OP *firstkid;
OP *kid;
HV * const hinthv =
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 */
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)
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;
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 */
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 */
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 *
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;
"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;
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;
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);
}
{
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;
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;
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;
}
}
}
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;
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 != '_'))
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);
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
{
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);
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;
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;
}
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)
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;
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;
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 */
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. */
*/
{
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);
}
}
}
&& (!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;
}
&& !(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;
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;
}
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
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);
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;
(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);
|| 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;
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. */
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. */
* 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;
static void
const_sv_xsub(pTHX_ CV* cv)
{
- dVAR;
dXSARGS;
SV *const sv = MUTABLE_SV(XSANY.any_ptr);
PERL_UNUSED_ARG(items);
static void
const_av_xsub(pTHX_ CV* cv)
{
- dVAR;
dXSARGS;
AV * const av = MUTABLE_AV(XSANY.any_ptr);
SP -= items;
* !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
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
and C<OP_TYPE_ISNT_AND_WASNT_NN> 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
*/
#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))
PADLIST *
Perl_pad_new(pTHX_ int flags)
{
- dVAR;
PADLIST *padlist;
PAD *padname, *pad;
PAD **ary;
void
Perl_cv_undef(pTHX_ CV *cv)
{
- dVAR;
const PADLIST *padlist = CvPADLIST(cv);
bool const slabbed = !!CvSLABBED(cv);
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;
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;
PADOFFSET
Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
{
- dVAR;
SV *sv;
I32 retval;
PADOFFSET
Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
{
- dVAR;
PADOFFSET ix;
SV* const name = newSV_type(SVt_PVNV);
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;
PADOFFSET
Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
{
- dVAR;
SV *out_sv;
int out_flags;
I32 offset;
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,
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;
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);
U32
Perl_intro_my(pTHX)
{
- dVAR;
SV **svp;
I32 i;
U32 seq;
OP *
Perl_pad_leavemy(pTHX)
{
- dVAR;
I32 off;
OP *o = NULL;
SV * const * const svp = AvARRAY(PL_comppad_name);
void
Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
{
- dVAR;
ASSERT_CURPAD_LEGAL("pad_swipe");
if (!PL_curpad)
return;
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",
void
Perl_pad_free(pTHX_ PADOFFSET po)
{
- dVAR;
SV *sv;
ASSERT_CURPAD_LEGAL("pad_free");
if (!PL_curpad)
void
Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
{
- dVAR;
const AV *pad_name;
const AV *pad;
SV **pname;
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);
static CV *
S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
const bool newcv = !cv;
assert(!CvUNIQUE(proto));
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];
void
Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
{
- dVAR;
-
PERL_ARGS_ASSERT_PAD_PUSH;
if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
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;
}
PAD **
Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
{
- dVAR;
PAD **ary;
SSize_t const oldmax = PadlistMAX(padlist);
*/
#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))
#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
*/
#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
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;
int
perl_run(pTHXx)
{
- dVAR;
I32 oldscope;
int ret = 0;
dJMPENV;
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)));
/* See G_* flags in cop.h */
/* null terminated arg list */
{
- dVAR;
dSP;
PERL_ARGS_ASSERT_CALL_ARGV;
SV*
Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
{
- dVAR;
SV* sv = newSVpv(p, 0);
PERL_ARGS_ASSERT_EVAL_PV;
void
Perl_require_pv(pTHX_ const char *pv)
{
- dVAR;
dSP;
SV* sv;
void
Perl_my_unexec(pTHX)
{
- PERL_UNUSED_CONTEXT;
#ifdef UNEXEC
SV * prog = newSVpv(BIN_EXP, 0);
SV * file = newSVpv(PL_origfilename, 0);
/* 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
STATIC void
S_init_interp(pTHX)
{
- dVAR;
#ifdef MULTIPLICITY
# define PERLVAR(prefix,var,type)
# define PERLVARA(prefix,var,n,type)
STATIC void
S_init_main_stash(pTHX)
{
- dVAR;
GV *gv;
PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV());
{
int fdscript = -1;
PerlIO *rsfp = NULL;
- dVAR;
Stat_t tmpstatbuf;
int fd;
STATIC void
S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
{
- dVAR;
const char *s;
const char *s2;
/* 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)) );
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;
void
Perl_init_debugger(pTHX)
{
- dVAR;
HV * const ostash = PL_curstash;
PL_curstash = (HV *)SvREFCNT_inc_simple(PL_debstash);
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));
STATIC void
S_nuke_stacks(pTHX)
{
- dVAR;
while (PL_curstackinfo->si_next)
PL_curstackinfo = PL_curstackinfo->si_next;
while (PL_curstackinfo) {
STATIC void
S_init_predump_symbols(pTHX)
{
- dVAR;
GV *tmpgv;
IO *io;
void
Perl_init_argv_symbols(pTHX_ int argc, char **argv)
{
- dVAR;
-
PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS;
argc--,argv++; /* skip name of script */
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;
STATIC void
S_init_perllib(pTHX)
{
- dVAR;
#ifndef VMS
const char *perl5lib = NULL;
#endif
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;
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
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;
void
Perl_my_exit(pTHX_ U32 status)
{
- dVAR;
if (PL_exit_flags & PERL_EXIT_ABORT) {
abort();
}
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
STATIC void
S_my_exit_jump(pTHX)
{
- dVAR;
-
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
PL_e_script = NULL;
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');
# 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
* 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.)
# 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
* 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
#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
# ifdef USE_LOCALE_NUMERIC
" USE_LOCALE_NUMERIC"
# endif
+# ifdef USE_LOCALE_TIME
+ " USE_LOCALE_TIME"
+# endif
# ifdef USE_LONG_DOUBLE
" USE_LONG_DOUBLE"
# endif
#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)
#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? */
PerlIO *
PerlIO_allocate(pTHX)
{
- dVAR;
/*
* Find a free slot in the table, allocating new table as necessary
*/
void
PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
{
- dVAR;
PerlIO_pair_t *p;
PERL_UNUSED_CONTEXT;
void
PerlIO_destruct(pTHX)
{
- dVAR;
PerlIOl **table = &PL_perlio;
PerlIOl *f;
#ifdef USE_ITHREADS
AV *
PerlIO_get_layers(pTHX_ PerlIO *f)
{
- dVAR;
AV * const av = newAV();
if (PerlIOValid(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);
/* This is used as a %SIG{__WARN__} handler to suppress warnings
during loading of layers.
*/
- dVAR;
dXSARGS;
PERL_UNUSED_ARG(cv);
if (items)
XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
XS(XS_PerlIO__Layer__find)
{
- dVAR;
dXSARGS;
PERL_UNUSED_ARG(cv);
if (items < 2)
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);
int
PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
{
- dVAR;
if (names) {
const char *s = names;
while (*s) {
void
PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
{
- dVAR;
PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
#ifdef PERLIO_USING_CRLF
tab = &PerlIO_crlf;
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;
PerlIO_funcs *
PerlIO_default_layer(pTHX_ I32 n)
{
- dVAR;
PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
if (n < 0)
n += av->cur;
void
PerlIO_stdstreams(pTHX)
{
- dVAR;
if (!PL_perlio) {
PerlIO_init_table(aTHX);
PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
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
*/
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)
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)
int
Perl_PerlIO_flush(pTHX_ PerlIO *f)
{
- dVAR;
if (f) {
if (*f) {
const PerlIO_funcs *tab = PerlIOBase(f)->tab;
void
PerlIOBase_flush_linebuf(pTHX)
{
- dVAR;
PerlIOl **table = &PL_perlio;
PerlIOl *f;
while ((f = *table)) {
void
PerlIO_cleanup(pTHX)
{
- dVAR;
int i;
#ifdef USE_ITHREADS
PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
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;
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;
IV
PerlIOUnix_close(pTHX_ PerlIO *f)
{
- dVAR;
const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
int code = 0;
if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
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 */
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;
void
PerlIO_releaseFILE(PerlIO *p, FILE *f)
{
- dVAR;
PerlIOl *l;
while ((l = *p)) {
if (l->tab == &PerlIO_stdio) {
PerlIO *
Perl_PerlIO_stdin(pTHX)
{
- dVAR;
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
PerlIO *
Perl_PerlIO_stdout(pTHX)
{
- dVAR;
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
PerlIO *
Perl_PerlIO_stderr(pTHX)
{
- dVAR;
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
const char *
Perl_PerlIO_context_layers(pTHX_ const char *mode)
{
- dVAR;
const char *direction = NULL;
SV *layers;
/*
int
Perl_yyparse (pTHX_ int gramtype)
{
- dVAR;
int yystate;
int yyn;
int yyresult;
* 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
* 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.
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=''
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=''
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'
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'
strerror_r_proto='0'
strings='/sys/include/ape/string.h'
submit=''
-subversion='1'
+subversion='2'
sysman='/sys/man/1pub'
tail=''
tar=''
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=''
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
/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
/perlmacos.pod
/perlmacosx.pod
/perlmodlib.pod
-/perlmpeix.pod
/perlnetware.pod
/perlopenbsd.pod
/perlos2.pod
/perltru64.pod
/perltw.pod
/perluniprops.pod
-/perluts.pod
-/perlvmesa.pod
/perlvms.pod
/perlvos.pod
/perlwin32.pod
/roffitall
# generated
-/perl5211delta.pod
+/perl5212delta.pod
/perlapi.pod
/perlintern.pod
*.html
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
--- /dev/null
+=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<perl5210delta>, 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</"Incompatible Changes">
+for more information.
+
+=head1 Core Enhancements
+
+=head2 Unicode 7.0 is now supported
+
+For details on what is in this release, see
+L<http://www.unicode.org/versions/Unicode7.0.0/>.
+
+=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<Configure -Dusecbacktrace>.
+
+Also included is a C API to retrieve backtraces.
+
+See L<perlhacktips/"C backtrace"> for more information.
+
+=head2 C<qr/foo/x> now ignores any Unicode pattern white space
+
+The C</x> 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<C<use locale>> can restrict which locale categories are affected
+
+It is now possible to pass a parameter to S<C<use locale>> to specify
+a subset of locale categories to be locale-aware, with the remaining
+ones unaffected. See L<perllocale/The "use locale" pragma> 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<X>>, I<X> 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</x> in
+regex patterns (unless escaped)
+
+The use of these characters with C</x> 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</"qr/foo/x">
+for the list of the five characters.
+
+=head2 Comment lines within S<C<(?[ ])>> now are ended only by a C<\n>
+
+S<C<(?[ ])>> is an experimental feature, introduced in v5.18. It operates
+as if C</x> 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<C<(?[ ])>>, 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<?PATTERN?> 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<m?PATTERN?> instead,
+explicitly using the C<m> operator: the question mark delimiter still
+invokes match-once behaviour.
+
+=head2 C<defined(@array)> and C<defined(%hash)> 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<gt>{"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<charnames/CUSTOM ALIASES>.
+
+=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<perl #121489|https://rt.perl.org/Ticket/Display.html?id=121489>
+
+=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<Archive::Tar> has been upgraded from version 1.96 to 2.00.
+
+=item *
+
+L<autodie> has been upgraded from version 2.23 to 2.25.
+
+=item *
+
+L<B> has been upgraded from version 1.48 to 1.49.
+
+=item *
+
+L<B::Deparse> has been upgraded from version 1.26 to 1.27.
+
+=item *
+
+L<Benchmark> has been upgraded from version 1.18 to 1.19.
+
+=item *
+
+L<Carp> 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<charnames> has been upgraded from version 1.40 to 1.41.
+
+=item *
+
+L<CPAN::Meta> has been upgraded from version 2.140640 to 2.141520.
+
+=item *
+
+L<Data::Dumper> 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<Devel::Peek> has been upgraded from version 1.16 to 1.17.
+
+=item *
+
+L<Devel::PPPort> has been upgraded from version 3.21 to 3.24.
+
+=item *
+
+L<Digest::SHA> has been upgraded from version 5.88 to 5.92.
+
+=item *
+
+L<DynaLoader> has been upgraded from version 1.25 to 1.26.
+
+=item *
+
+L<Encode> has been upgraded from version 2.60 to 2.62.
+
+B<piconv> now has better error handling when the encoding name is nonexistent,
+and a build breakage when upgrading L<Encode> in perl-5.8.2 and earlier has
+been fixed.
+
+=item *
+
+L<Errno> has been upgraded from version 1.20_03 to 1.20_04.
+
+=item *
+
+L<Exporter> has been upgraded from version 5.70 to 5.71.
+
+=item *
+
+L<ExtUtils::Install> has been upgraded from version 1.67 to 1.68.
+
+=item *
+
+L<ExtUtils::Miniperl> has been upgraded from version 1.01 to 1.02.
+
+=item *
+
+L<ExtUtils::ParseXS> has been upgraded from version 3.24 to 3.25.
+
+=item *
+
+L<ExtUtils::Typemaps> has been upgraded from version 3.24 to 3.25.
+
+=item *
+
+L<File::Spec> has been upgraded from version 3.47 to 3.48.
+
+=item *
+
+L<Hash::Util> has been upgraded from version 0.16 to 0.17.
+
+Minor bug fixes and documentation fixes to Hash::Util::hash_stats()
+
+=item *
+
+L<IO> has been upgraded from version 1.31 to 1.32.
+
+=item *
+
+L<List::Util> has been upgraded from version 1.38 to 1.39.
+
+=item *
+
+L<locale> has been upgraded from version 1.03 to 1.04.
+
+=item *
+
+L<Locale::Codes> has been upgraded from version 3.30 to 3.31.
+
+=item *
+
+L<Math::BigInt> 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<Math::BigRat> has been upgraded from version 0.2606 to 0.2608.
+
+Synchronize POD changes from the CPAN release.
+
+=item *
+
+L<Module::CoreList> has been upgraded from version 5.021001 to 5.021001_01.
+
+=item *
+
+L<Module::Metadata> has been upgraded from version 1.000019 to 1.000024.
+
+Support installations on older perls with an L<ExtUtils::MakeMaker> earlier
+than 6.63_03
+
+=item *
+
+L<NDBM_File> has been upgraded from version 1.12 to 1.13.
+
+=item *
+
+L<OS2::Process> has been upgraded from version 1.09 to 1.10.
+
+=item *
+
+L<perl5db.pl> has been upgraded from version 1.44 to 1.45.
+
+fork() in the debugger under C<tmux> 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<R> or C<rerun>. L<[perl
+#121509]|https://rt.perl.org/Ticket/Display.html?id=121509>
+
+=item *
+
+L<PerlIO::encoding> has been upgraded from version 0.18 to 0.19.
+
+No changes in behaviour.
+
+=item *
+
+L<PerlIO::mmap> has been upgraded from version 0.011 to 0.013.
+
+No changes in behaviour.
+
+=item *
+
+L<PerlIO::scalar> has been upgraded from version 0.18 to 0.19.
+
+No changes in behaviour.
+
+=item *
+
+L<PerlIO::via> has been upgraded from version 0.14 to 0.15.
+
+=item *
+
+L<Pod::Html> has been upgraded from version 1.21 to 1.22.
+
+=item *
+
+L<POSIX> has been upgraded from version 1.38_03 to 1.40.
+
+=item *
+
+L<Scalar::Util> has been upgraded from version 1.38 to 1.39.
+
+=item *
+
+L<SelfLoader> has been upgraded from version 1.21 to 1.22.
+
+=item *
+
+L<Socket> has been upgraded from version 2.013 to 2.014.
+
+=item *
+
+L<Storable> has been upgraded from version 2.49 to 2.51.
+
+=item *
+
+L<Term::ANSIColor> has been upgraded from version 4.02 to 4.03.
+
+=item *
+
+L<Test::Harness> has been upgraded from version 3.30 to 3.32.
+
+=item *
+
+L<Test::Simple> has been upgraded from version 1.001002 to 1.001003.
+
+=item *
+
+L<threads> has been upgraded from version 1.93 to 1.94.
+
+=item *
+
+L<Tie::File> has been upgraded from version 1.00 to 1.01.
+
+=item *
+
+L<Unicode::Collate> 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<Unicode::Normalize> has been upgraded from version 1.17 to 1.18.
+
+The XSUB implementation has been removed in favour of pure Perl.
+
+=item *
+
+L<Unicode::UCD> has been upgraded from version 0.57 to 0.58.
+
+=item *
+
+L<utf8> has been upgraded from version 1.13 to 1.14.
+
+=item *
+
+L<warnings> has been upgraded from version 1.23 to 1.24.
+
+=back
+
+=head1 Documentation
+
+=head2 Changes to Existing Documentation
+
+=head3 L<perlfunc>
+
+=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<exec LIST> and C<system LIST> may fall back to the shell on
+Win32. Only C<exec PROGRAM LIST> and C<system PROGRAM LIST> indirect object
+syntax will reliably avoid using the shell.
+
+This has also been noted in L<perlport>.
+
+L<[perl #122046]|https://rt.perl.org/Ticket/Display.html?id=122046>
+
+=back
+
+=head3 L<perlapi>
+
+=over 4
+
+=item *
+
+Note that C<SvSetSV> doesn't do set magic.
+
+=item *
+
+C<sv_usepvn_flags> - Fix documentation to mention the use of C<NewX> instead of
+C<malloc>.
+
+L<[perl #121869]|https://rt.perl.org/Ticket/Display.html?id=121869>
+
+=item *
+
+Clarify where C<NUL> 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<perlhacktips>
+
+=over 4
+
+=item *
+
+Updated documentation for the C<test.valgrind> C<make> target.
+
+L<[perl #121431]|https://rt.perl.org/Ticket/Display.html?id=121431>
+
+=back
+
+=head3 L<perlre>
+
+=over 4
+
+=item *
+
+The C</x> modifier has been clarified to note that comments cannot be continued
+onto the next line by escaping them.
+
+=back
+
+=head3 L<Unicode::UCD>
+
+=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<perldiag>.
+
+=head2 New Diagnostics
+
+=head3 New Errors
+
+=over 4
+
+=item *
+
+L<In '(?...)', the '(' and '?' must be adjacent in regex; marked by S<<-- HERE> in mE<sol>%sE<sol>|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 '(*VERB...)', the '(' and '*' must be adjacent in regex; marked by S<<-- HERE> in mE<sol>%sE<sol>|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<charnames alias definitions may not contain a sequence of multiple spaces|perldiag/"charnames alias definitions may not contain a sequence of multiple spaces">
+
+(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<use charnames>, but
+ they could be defined by a translator installed into C<$^H{charnames}>.
+ See L<charnames/CUSTOM ALIASES>.
+
+=item *
+
+L<charnames alias definitions may not contain trailing white-space|perldiag/"charnames alias definitions may not contain trailing white-space">
+
+(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<use charnames>, but they
+could be defined by a translator installed into C<$^H{charnames}>.
+See L<charnames/CUSTOM ALIASES>.
+
+=item *
+
+L<Can't use a hash as a reference|perldiag/"Can't use a hash as a reference">
+
+(F) You tried to use a hash as a reference, as in
+C<< %foo->{"bar"} >> or C<< %$ref->{"hello"} >>. Versions of perl E<lt>= 5.6.1
+used to allow this syntax, but shouldn't have.
+
+=item *
+
+L<Can't use an array as a reference|perldiag/"Can't use an array as a reference">
+
+(F) You tried to use an array as a reference, as in
+C<< @foo->[23] >> or C<< @$ref->[99] >>. Versions of perl E<lt>= 5.6.1 used to
+allow this syntax, but shouldn't have.
+
+=item *
+
+L<Can't use 'defined(@array)' (Maybe you should just omit the defined()?)|perldiag/"Can't use 'defined(@array)' (Maybe you should just omit the defined()?)">
+
+(F) defined() is not useful on arrays because it
+checks for an undefined I<scalar> value. If you want to see if the
+array is empty, just use C<if (@array) { # not empty }> for example.
+
+=item *
+
+L<Can't use 'defined(%hash)' (Maybe you should just omit the defined()?)|perldiag/"Can't use 'defined(%hash)' (Maybe you should just omit the defined()?)">
+
+(F) C<defined()> is not usually right on hashes.
+
+Although C<defined %hash> 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<undef %hash>.
+These things make C<defined %hash> 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<perldata/Scalar values>):
+
+ if (%hash) {
+ # not empty
+ }
+
+If you had C<defined %Foo::Bar::QUUX> 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<Illegal suidscript|perldiag/"Illegal suidscript">
+
+(F) The script run under suidperl was somehow illegal.
+
+=back
+
+=head3 New Warnings
+
+=over 4
+
+=item *
+
+L<Unescaped left brace in regex is deprecated, passed through in regex; marked by <-- HERE in mE<sol>%sE<sol>|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<NO-BREAK SPACE in a charnames alias definition is deprecated|perldiag/"NO-BREAK SPACE in a charnames alias definition is deprecated">
+
+(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<use charnames>, but they
+could be defined by a translator installed into C<$^H{charnames}>. See
+L<charnames/CUSTOM ALIASES>.
+
+=item *
+
+L<PerlIO layer ':win32' is experimental|perldiag/"PerlIO layer ':win32' is experimental">
+
+(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<Negative repeat count does nothing|perldiag/"Negative repeat count does nothing">
+
+(W numeric) You tried to execute the
+L<C<x>|perlop/Multiplicative Operators> repetition operator fewer than 0
+times, which doesn't make sense.
+
+=item *
+
+L<localtime(%f) failed|perldiag/"localtime(%f) failed">
+
+(W overflow) You called C<localtime> with a number that it could not handle:
+too large, too small, or NaN. The returned value is C<undef>.
+
+=item *
+
+L<gmtime(%f) failed|perldiag/"gmtime(%f) failed">
+
+(W overflow) You called C<gmtime> with a number that it could not handle:
+too large, too small, or NaN. The returned value is C<undef>.
+
+=item *
+
+L<PerlIO layer ':win32' is experimental|perldiag/"PerlIO layer ':win32' is experimental">:
+
+(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<Negative repeat count does nothing|perldiag/"Negative repeat count does nothing">
+
+(W numeric) This warns when the repeat count of the
+L<C<x>|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<Variable length lookbehind not implemented in regex mE<sol>%sE<sol>|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<Unsuccessful %s on filename containing newline|perldiag/"Unsuccessful %s on filename containing newline">
+
+This warning is now only produced when the newline is at the end of
+the filename.
+
+=back
+
+=head1 Utility Changes
+
+=head2 F<x2p/>
+
+=over 4
+
+=item *
+
+The F<x2p/> 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<make test.valgrind> now supports parallel testing.
+
+For example:
+
+ TEST_JOBS=9 make test.valgrind
+
+See L<perlhacktips/valgrind> 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<malloc> 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<PL_sv_objcount> has been removed.
+
+=item *
+
+Perl now tries to keep the locale category C<LC_NUMERIC> 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<POSIX::setlocale()> would change it. Now such a call will change the
+underlying locale of the C<LC_NUMERIC> 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<mailto:perl5-porters@perl.org> for
+guidance.
+
+=item *
+
+A new macro L<C<isUTF8_CHAR>|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<POSIX::localeconv()> now returns the data for the program's underlying
+locale even when called from outside the scope of S<C<use locale>>.
+
+=item *
+
+C<POSIX::localeconv()> now works properly on platforms which don't have
+C<LC_NUMERIC> and/or C<LC_MONETARY>, 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<localeconv()>.
+
+=item *
+
+C<POSIX::localeconv()> 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<S<use locale>>, 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<Coverity|http://www.coverity.com/> 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</bin/sh>
+instead of C</system/bin/sh>, and so would fail for the vast majority
+of devices, leaving C<$!> as C<ENOENT>.
+
+=item *
+
+C<qr(...\(...\)...)>,
+C<qr[...\[...\]...]>,
+and
+C<qr{...\{...\}...}>
+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<AUTHORS> 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<perlbug> 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<perl -V>,
+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<Changes> file for an explanation of how to view exhaustive details on
+what changed.
+
+The F<INSTALL> file for how to build Perl.
+
+The F<README> file for general stuff.
+
+The F<Artistic> and F<Copying> files for copyright information.
+
+=cut
=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<perl5210delta>, 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</"Incompatible Changes">
-for more information.
+If you are upgrading from an earlier release such as 5.21.0, first read
+L<perl5211delta>, 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<http://www.unicode.org/versions/Unicode7.0.0/>.
-
-=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<Configure -Dusecbacktrace>.
-
-Also included is a C API to retrieve backtraces.
-
-See L<perlhacktips/"C backtrace"> for more information.
-
-=head2 C<qr/foo/x> now ignores any Unicode pattern white space
-
-The C</x> 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<C<use locale>> can restrict which locale categories are affected
-
-It is now possible to pass a parameter to S<C<use locale>> to specify
-a subset of locale categories to be locale-aware, with the remaining
-ones unaffected. See L<perllocale/The "use locale" pragma> 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<X>>, I<X> 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</x> in
-regex patterns (unless escaped)
+=head2 Better heuristics on older platforms for determining locale UTF8ness
-The use of these characters with C</x> 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</"qr/foo/x">
-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<C<(?[ ])>> now are ended only by a C<\n>
+=head1 Security
-S<C<(?[ ])>> is an experimental feature, introduced in v5.18. It operates
-as if C</x> 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<C<(?[ ])>>, 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<?PATTERN?> 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<m?PATTERN?> instead,
-explicitly using the C<m> operator: the question mark delimiter still
-invokes match-once behaviour.
-
-=head2 C<defined(@array)> and C<defined(%hash)> 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<gt>{"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<charnames/CUSTOM ALIASES>.
-
-=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
=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<perl #121489|https://rt.perl.org/Ticket/Display.html?id=121489>
-
-=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<Archive::Tar> has been upgraded from version 1.96 to 2.00.
-
-=item *
-
-L<autodie> has been upgraded from version 2.23 to 2.25.
-
-=item *
-
-L<B> has been upgraded from version 1.48 to 1.49.
-
-=item *
-
-L<B::Deparse> has been upgraded from version 1.26 to 1.27.
-
-=item *
-
-L<Benchmark> has been upgraded from version 1.18 to 1.19.
-
-=item *
-
-L<Carp> 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<charnames> has been upgraded from version 1.40 to 1.41.
-
-=item *
-
-L<CPAN::Meta> has been upgraded from version 2.140640 to 2.141520.
-
-=item *
-
-L<Data::Dumper> 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<Devel::Peek> has been upgraded from version 1.16 to 1.17.
-
-=item *
-
-L<Devel::PPPort> has been upgraded from version 3.21 to 3.24.
-
-=item *
-
-L<Digest::SHA> has been upgraded from version 5.88 to 5.92.
-
-=item *
-
-L<DynaLoader> has been upgraded from version 1.25 to 1.26.
-
-=item *
-
-L<Encode> has been upgraded from version 2.60 to 2.62.
-
-B<piconv> now has better error handling when the encoding name is nonexistent,
-and a build breakage when upgrading L<Encode> in perl-5.8.2 and earlier has
-been fixed.
-
-=item *
-
-L<Errno> has been upgraded from version 1.20_03 to 1.20_04.
-
-=item *
-
-L<Exporter> has been upgraded from version 5.70 to 5.71.
-
-=item *
-
-L<ExtUtils::Install> has been upgraded from version 1.67 to 1.68.
-
-=item *
-
-L<ExtUtils::Miniperl> has been upgraded from version 1.01 to 1.02.
-
-=item *
-
-L<ExtUtils::ParseXS> has been upgraded from version 3.24 to 3.25.
-
-=item *
-
-L<ExtUtils::Typemaps> has been upgraded from version 3.24 to 3.25.
-
-=item *
-
-L<File::Spec> has been upgraded from version 3.47 to 3.48.
-
-=item *
-
-L<Hash::Util> 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<IO> has been upgraded from version 1.31 to 1.32.
+Pathtools don't try to load XS on miniperl.
=item *
-L<List::Util> has been upgraded from version 1.38 to 1.39.
+A typo fix reduces the size of the C<< OP >> structure.
=item *
-L<locale> has been upgraded from version 1.03 to 1.04.
+Hash lookups where the key is a constant is faster.
-=item *
-
-L<Locale::Codes> has been upgraded from version 3.30 to 3.31.
-
-=item *
-
-L<Math::BigInt> 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<Math::BigRat> has been upgraded from version 0.2606 to 0.2608.
-
-Synchronize POD changes from the CPAN release.
-
-=item *
-
-L<Module::CoreList> has been upgraded from version 5.021001 to 5.021001_01.
-
-=item *
-
-L<Module::Metadata> has been upgraded from version 1.000019 to 1.000024.
-
-Support installations on older perls with an L<ExtUtils::MakeMaker> earlier
-than 6.63_03
-
-=item *
+=back
-L<NDBM_File> has been upgraded from version 1.12 to 1.13.
+=head1 Modules and Pragmata
-=item *
+=head2 Updated Modules and Pragmata
-L<OS2::Process> has been upgraded from version 1.09 to 1.10.
+=over 4
=item *
-L<perl5db.pl> has been upgraded from version 1.44 to 1.45.
-
-fork() in the debugger under C<tmux> 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<R> or C<rerun>. L<[perl
-#121509]|https://rt.perl.org/Ticket/Display.html?id=121509>
+L<arybase> has been upgraded from version 0.07 to 0.08.
=item *
-L<PerlIO::encoding> has been upgraded from version 0.18 to 0.19.
-
-No changes in behaviour.
+L<B> has been upgraded from version 1.49 to 1.50.
=item *
-L<PerlIO::mmap> has been upgraded from version 0.011 to 0.013.
-
-No changes in behaviour.
+L<Devel::Peek> has been upgraded from version 1.17 to 1.18.
=item *
-L<PerlIO::scalar> has been upgraded from version 0.18 to 0.19.
-
-No changes in behaviour.
+L<experimental> has been upgraded from version 0.007 to 0.008.
=item *
-L<PerlIO::via> has been upgraded from version 0.14 to 0.15.
+L<ExtUtils::Manifest> has been upgraded from version 1.63 to 1.64.
=item *
-L<Pod::Html> has been upgraded from version 1.21 to 1.22.
+L<File::Copy> has been upgraded from version 2.29 to 2.30.
=item *
-L<POSIX> has been upgraded from version 1.38_03 to 1.40.
+The PathTools module collection (L<File::Spec> and friends) has been
+upgraded from version 3.48 to 3.49.
=item *
-L<Scalar::Util> has been upgraded from version 1.38 to 1.39.
+L<Filter::Simple> has been upgraded from version 0.91 to 0.92.
=item *
-L<SelfLoader> has been upgraded from version 1.21 to 1.22.
+L<Hash::Util> has been upgraded from version 0.17 to 0.18.
=item *
-L<Socket> has been upgraded from version 2.013 to 2.014.
+L<IO> has been upgraded from version 1.32 to 1.33.
=item *
-L<Storable> has been upgraded from version 2.49 to 2.51.
+L<IO::Socket::IP> has been upgraded from version 0.29 to 0.31.
-=item *
-
-L<Term::ANSIColor> has been upgraded from version 4.02 to 4.03.
+A better fix for subclassing C<connect()>.
+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<Test::Harness> has been upgraded from version 3.30 to 3.32.
+L<IPC::Open3> has been upgraded from version 1.16 to 1.17.
=item *
-L<Test::Simple> has been upgraded from version 1.001002 to 1.001003.
-
-=item *
-
-L<threads> has been upgraded from version 1.93 to 1.94.
-
-=item *
+L<Math::BigInt> has been upgraded from version 1.9995 to 1.9996.
-L<Tie::File> 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<Unicode::Collate> 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<Module::CoreList> has been upgraded from version 5.021001_01 to 5.021002.
=item *
-L<Unicode::Normalize> has been upgraded from version 1.17 to 1.18.
-
-The XSUB implementation has been removed in favour of pure Perl.
+L<Pod::Usage> has been upgraded from version 1.63 to 1.64.
=item *
-L<Unicode::UCD> has been upgraded from version 0.57 to 0.58.
+L<POSIX> has been upgraded from version 1.40 to 1.41.
=item *
-L<utf8> has been upgraded from version 1.13 to 1.14.
+L<threads> has been upgraded from version 1.94 to 1.95.
=item *
-L<warnings> has been upgraded from version 1.23 to 1.24.
+L<warnings> has been upgraded from version 1.24 to 1.26.
=back
=head2 Changes to Existing Documentation
-=head3 L<perlfunc>
+=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<exec LIST> and C<system LIST> may fall back to the shell on
-Win32. Only C<exec PROGRAM LIST> and C<system PROGRAM LIST> indirect object
-syntax will reliably avoid using the shell.
-
-This has also been noted in L<perlport>.
-
-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<perlapi>
+=head3 L<< perlfunc >>
=over 4
=item *
-Note that C<SvSetSV> doesn't do set magic.
-
-=item *
-
-C<sv_usepvn_flags> - Fix documentation to mention the use of C<NewX> instead of
-C<malloc>.
-
-L<[perl #121869]|https://rt.perl.org/Ticket/Display.html?id=121869>
-
-=item *
-
-Clarify where C<NUL> 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<perlhacktips>
+=head3 L<< perlsyn >>
=over 4
=item *
-Updated documentation for the C<test.valgrind> C<make> target.
-
-L<[perl #121431]|https://rt.perl.org/Ticket/Display.html?id=121431>
-
-=back
-
-=head3 L<perlre>
-
-=over 4
-
-=item *
-
-The C</x> modifier has been clarified to note that comments cannot be continued
-onto the next line by escaping them.
-
-=back
-
-=head3 L<Unicode::UCD>
-
-=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<perldiag>.
-
=head2 New Diagnostics
-=head3 New Errors
-
-=over 4
-
-=item *
-
-L<In '(?...)', the '(' and '?' must be adjacent in regex; marked by S<<-- HERE> in mE<sol>%sE<sol>|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 '(*VERB...)', the '(' and '*' must be adjacent in regex; marked by S<<-- HERE> in mE<sol>%sE<sol>|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<charnames alias definitions may not contain a sequence of multiple spaces|perldiag/"charnames alias definitions may not contain a sequence of multiple spaces">
-
-(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<use charnames>, but
- they could be defined by a translator installed into C<$^H{charnames}>.
- See L<charnames/CUSTOM ALIASES>.
-
-=item *
-
-L<charnames alias definitions may not contain trailing white-space|perldiag/"charnames alias definitions may not contain trailing white-space">
-
-(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<use charnames>, but they
-could be defined by a translator installed into C<$^H{charnames}>.
-See L<charnames/CUSTOM ALIASES>.
-
-=item *
-
-L<Can't use a hash as a reference|perldiag/"Can't use a hash as a reference">
-
-(F) You tried to use a hash as a reference, as in
-C<< %foo->{"bar"} >> or C<< %$ref->{"hello"} >>. Versions of perl E<lt>= 5.6.1
-used to allow this syntax, but shouldn't have.
-
-=item *
-
-L<Can't use an array as a reference|perldiag/"Can't use an array as a reference">
-
-(F) You tried to use an array as a reference, as in
-C<< @foo->[23] >> or C<< @$ref->[99] >>. Versions of perl E<lt>= 5.6.1 used to
-allow this syntax, but shouldn't have.
-
-=item *
-
-L<Can't use 'defined(@array)' (Maybe you should just omit the defined()?)|perldiag/"Can't use 'defined(@array)' (Maybe you should just omit the defined()?)">
-
-(F) defined() is not useful on arrays because it
-checks for an undefined I<scalar> value. If you want to see if the
-array is empty, just use C<if (@array) { # not empty }> for example.
-
-=item *
-
-L<Can't use 'defined(%hash)' (Maybe you should just omit the defined()?)|perldiag/"Can't use 'defined(%hash)' (Maybe you should just omit the defined()?)">
-
-(F) C<defined()> is not usually right on hashes.
-
-Although C<defined %hash> 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<undef %hash>.
-These things make C<defined %hash> 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<perldata/Scalar values>):
-
- if (%hash) {
- # not empty
- }
-
-If you had C<defined %Foo::Bar::QUUX> 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<Illegal suidscript|perldiag/"Illegal suidscript">
-
-(F) The script run under suidperl was somehow illegal.
-
-=back
-
=head3 New Warnings
=over 4
=item *
-L<Unescaped left brace in regex is deprecated, passed through in regex; marked by <-- HERE in mE<sol>%sE<sol>|perldiag/"Unescaped left brace in regex is deprecated, passed through in regex; marked by <-- HERE in m/%s/">
+L<Argument "%s" treated as 0 in increment (++)|perldiag/"Argument "%s" treated
+as 0 in increment (++)">
-(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</^[a-zA-Z]*[0-9]*\z/>.
+See L<perlop/Auto-increment and Auto-decrement> for details.
=item *
-L<NO-BREAK SPACE in a charnames alias definition is deprecated|perldiag/"NO-BREAK SPACE in a charnames alias definition is deprecated">
+L<Redundant argument in %s|perldiag/Redundant argument in %s>
-(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<use charnames>, but they
-could be defined by a translator installed into C<$^H{charnames}>. See
-L<charnames/CUSTOM ALIASES>.
+(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<perlfunc/pack>.
-=item *
-
-L<PerlIO layer ':win32' is experimental|perldiag/"PerlIO layer ':win32' is experimental">
-
-(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<Negative repeat count does nothing|perldiag/"Negative repeat count does nothing">
-
-(W numeric) You tried to execute the
-L<C<x>|perlop/Multiplicative Operators> repetition operator fewer than 0
-times, which doesn't make sense.
-
-=item *
-
-L<localtime(%f) failed|perldiag/"localtime(%f) failed">
-
-(W overflow) You called C<localtime> with a number that it could not handle:
-too large, too small, or NaN. The returned value is C<undef>.
-
-=item *
-
-L<gmtime(%f) failed|perldiag/"gmtime(%f) failed">
-
-(W overflow) You called C<gmtime> with a number that it could not handle:
-too large, too small, or NaN. The returned value is C<undef>.
-
-=item *
-
-L<PerlIO layer ':win32' is experimental|perldiag/"PerlIO layer ':win32' is experimental">:
-
-(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<Negative repeat count does nothing|perldiag/"Negative repeat count does nothing">
-
-(W numeric) This warns when the repeat count of the
-L<C<x>|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<Variable length lookbehind not implemented in regex mE<sol>%sE<sol>|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<Unsuccessful %s on filename containing newline|perldiag/"Unsuccessful %s on filename containing newline">
-
-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<x2p/>
+=head1 Configuration and Compilation
=over 4
=item *
-The F<x2p/> 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<make test.valgrind> now supports parallel testing.
-
-For example:
-
- TEST_JOBS=9 make test.valgrind
-
-See L<perlhacktips/valgrind> 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<malloc> 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<perldtrace.h>. Added an
+explicit dependency to C<depend>.
+L<[perl #120120]|https://rt.perl.org/Ticket/Display.html?id=120120>
=back
=item *
-The deprecated variable C<PL_sv_objcount> has been removed.
+The following private API functions had their context parameter removed,
+C<Perl_cast_ulong>, C<Perl_cast_i32>, C<Perl_cast_iv>, C<Perl_cast_uv>,
+C<Perl_cv_const_sv>, C<Perl_mg_find>, C<Perl_mg_findext>, C<Perl_mg_magical>,
+C<Perl_mini_mktime>, C<Perl_my_dirfd>, C<Perl_sv_backoff>, C<Perl_utf8_hop>.
+
+Users of the public API prefix-less calls remain unaffected.
=item *
-Perl now tries to keep the locale category C<LC_NUMERIC> 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<POSIX::setlocale()> would change it. Now such a call will change the
-underlying locale of the C<LC_NUMERIC> 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<mailto:perl5-porters@perl.org> 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<C<isUTF8_CHAR>|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
=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<POSIX::localeconv()> now returns the data for the program's underlying
-locale even when called from outside the scope of S<C<use locale>>.
-
-=item *
-
-C<POSIX::localeconv()> now works properly on platforms which don't have
-C<LC_NUMERIC> and/or C<LC_MONETARY>, 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<localeconv()>.
+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<POSIX::localeconv()> 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<S<use locale>>, 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<Coverity|http://www.coverity.com/> 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</bin/sh>
-instead of C</system/bin/sh>, and so would fail for the vast majority
-of devices, leaving C<$!> as C<ENOENT>.
+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<qr(...\(...\)...)>,
-C<qr[...\[...\]...]>,
-and
-C<qr{...\{...\}...}>
-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
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</^[a-zA-Z]*[0-9]*\z/>. See L<perlop/Auto-increment and
+Auto-decrement> for details.
+
=item charnames alias definitions may not contain a sequence of multiple spaces
(F) You defined a character name which had multiple space
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()
=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<perlfunc/pack> 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<perlfunc/pack>.
=item Missing argument to -%c
=for Pod::Functions +5.6.0 declare and assign a package variable (lexical scoping)
-C<our> makes a lexical alias to a package variable of the same name in the current
-package for use within the current lexical scope.
+C<our> 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<our> has the same scoping rules as C<my> or C<state>, but C<our> only
-declares an alias, whereas C<my> or C<state> both declare a variable name and
-allocate storage for that name within the current scope.
+C<our> has the same scoping rules as C<my> or C<state>, meaning that it is
+only valid within a lexical scope. Unlike C<my> and C<state>, which both
+declare new (lexical) variables, C<our> only creates an alias to an
+existing variable: a package variable of the same name.
This means that when C<use strict 'vars'> is in effect, C<our> lets you use
a package variable without qualifying it with the package name, but only within
-the lexical scope of the C<our> declaration. In this way, C<our> differs from
-C<use vars>, which allows use of an unqualified name I<only> within the
-affected package, but across scopes.
+the lexical scope of the C<our> 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<our> declaration declares an alias for a package variable that will be visible
our ( undef, $min, $hour ) = localtime;
+C<our> differs from C<use vars>, which allows use of an unqualified name
+I<only> within the affected package, but across scopes.
+
=item pack TEMPLATE,LIST
X<pack>
add space for the trailing C<NUL> byte (perl's own string functions typically do
C<SvGROW(sv, len + 1)>).
+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.
op is a C<LISTOP>, which has any number of children. In this case, the
first child is pointed to by C<op_first> and the last child by
C<op_last>. The children in between can be found by iteratively
-following the C<op_sibling> pointer from the first child to the last.
+following the C<op_sibling> pointer from the first child to the last 9but
+see below).
-There are also
two other op types: a C<PMOP> holds a regular expression,
+There are also
some other op types: a C<PMOP> holds a regular expression,
and has no children, and a C<LOOP> may or may not have children. If the
C<op_children> field is non-zero, it behaves like a C<LISTOP>. To
complicate matters, if a C<UNOP> is actually a C<null> op after
optimization (see L</Compile pass 2: context propagation>) it will still
have children in accordance with its former type.
+Finally, there is a C<LOGOP>, or logic op. Like a C<LISTOP>, this has one
+or more children, but it doesn't have an C<op_last> field: so you have to
+follow C<op_first> and then the C<op_sibling> chain itself to find the
+last child. Instead it has an C<op_other> field, which is comparable to
+the C<op_next> field described below, and represents an alternate
+execution path. Operators like C<and>, C<or> and C<?> are C<LOGOP>s. Note
+that in general, C<op_other> may not point to any of the direct children
+of the C<LOGOP>.
+
+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<op_lastsib>. When set, this indicates that this is the last op in an
+C<op_sibling> chain. This frees up the C<op_sibling> field on the last
+sibling to point back to the parent op. The macro C<OP_SIBLING(o)> wraps
+this special behaviour, and always returns NULL on the last sibling.
+With this build the C<op_parent(o)> 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<B::Concise>.
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
+=encoding utf8
+
=head1 NAME
perlpolicy - Various and sundry policies and commitments related to the Perl core
=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 *
=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 *
=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 *
=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.
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.)
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
/(?<NAME>(?&NAME_PAT))(?<ADDR>(?&ADDRESS_PAT))
(?(DEFINE)
(?<NAME_PAT>....)
- (?<ADRESS_PAT>....)
+ (?<ADDRESS_PAT>....)
)/x
Note that capture groups matched inside of recursion are not accessible
and the control sections).
X<my>
+As a special case, if the test in the C<for> loop (or the corresponding
+C<while> 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<for> 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
PP(pp_stub)
{
- dVAR;
dSP;
if (GIMME_V == G_SCALAR)
XPUSHs(&PL_sv_undef);
PP(pp_padav)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
I32 gimme;
assert(SvTYPE(TARG) == SVt_PVAV);
if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
PP(pp_padhv)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
I32 gimme;
assert(SvTYPE(TARG) == SVt_PVHV);
PP(pp_padcv)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
assert(SvTYPE(TARG) == SVt_PVCV);
XPUSHs(TARG);
RETURN;
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);
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)) {
PP(pp_rv2gv)
{
- dVAR; dSP; dTOPss;
+ dSP; dTOPss;
sv = S_rv2gv(aTHX_
sv, PL_op->op_private & OPpDEREF,
Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
const svtype type, SV ***spp)
{
- dVAR;
GV *gv;
PERL_ARGS_ASSERT_SOFTREF2XV;
PP(pp_rv2sv)
{
- dVAR; dSP; dTOPss;
+ dSP; dTOPss;
GV *gv = NULL;
SvGETMAGIC(sv);
PP(pp_av2arylen)
{
- dVAR; dSP;
+ dSP;
AV * const av = MUTABLE_AV(TOPs);
const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
if (lvalue) {
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 */
PP(pp_rv2cv)
{
- dVAR; dSP;
+ dSP;
GV *gv;
HV *stash_unused;
const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
PP(pp_prototype)
{
- dVAR; dSP;
+ dSP;
CV *cv;
HV *stash;
GV *gv;
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))));
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;
STATIC SV*
S_refto(pTHX_ SV *sv)
{
- dVAR;
SV* rv;
PERL_ARGS_ASSERT_REFTO;
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)
PP(pp_gelem)
{
- dVAR; dSP;
+ dSP;
SV *sv = POPs;
STRLEN len;
PP(pp_study)
{
- dVAR; dSP; dPOPss;
+ dSP; dPOPss;
STRLEN len;
(void)SvPV(sv, len);
PP(pp_trans)
{
- dVAR; dSP; dTARG;
+ dSP; dTARG;
SV *sv;
if (PL_op->op_flags & OPf_STACKED)
static void
S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
{
- dVAR;
STRLEN len;
char *s;
PP(pp_schop)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
const bool chomping = PL_op->op_type == OP_SCHOMP;
if (chomping)
PP(pp_chop)
{
- dVAR; dSP; dMARK; dTARGET; dORIGMARK;
+ dSP; dMARK; dTARGET; dORIGMARK;
const bool chomping = PL_op->op_type == OP_CHOMP;
if (chomping)
PP(pp_undef)
{
- dVAR; dSP;
+ dSP;
SV *sv;
if (!PL_op->op_private) {
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)))
PP(pp_pow)
{
- dVAR; dSP; dATARGET; SV *svl, *svr;
+ dSP; dATARGET; SV *svl, *svr;
#ifdef PERL_PRESERVE_IVUV
bool is_int = 0;
#endif
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;
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;
PP(pp_modulo)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
{
UV left = 0;
PP(pp_repeat)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
IV count;
SV *sv;
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;
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;
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;
PP(pp_lt)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
PP(pp_gt)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
PP(pp_le)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
PP(pp_ge)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
PP(pp_ne)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
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 */
PP(pp_ncmp)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
I32 value;
tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
PP(pp_sle)
{
- dVAR; dSP;
+ dSP;
int amg_type = sle_amg;
int multiplier = 1;
PP(pp_seq)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(seq_amg, AMGf_set);
{
dPOPTOPssrl;
PP(pp_sne)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(sne_amg, AMGf_set);
{
dPOPTOPssrl;
PP(pp_scmp)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICbin_MG(scmp_amg, 0);
{
dPOPTOPssrl;
PP(pp_bit_and)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(band_amg, AMGf_assign);
{
dPOPTOPssrl;
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);
PP(pp_negate)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(neg_amg, AMGf_numeric);
if (S_negate_string(aTHX)) return NORMAL;
{
PP(pp_not)
{
- dVAR; dSP;
+ dSP;
tryAMAGICun_MG(not_amg, AMGf_set);
*PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
return NORMAL;
PP(pp_complement)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(compl_amg, AMGf_numeric);
{
dTOPss;
PP(pp_i_multiply)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(mult_amg, AMGf_assign);
{
dPOPTOPiirl_nomg;
PP(pp_i_divide)
{
IV num;
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(div_amg, AMGf_assign);
{
dPOPTOPssrl;
#endif
{
/* This is the vanilla old i_modulo. */
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(modulo_amg, AMGf_assign);
{
dPOPTOPiirl_nomg;
/* 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;
PP(pp_i_add)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(add_amg, AMGf_assign);
{
dPOPTOPiirl_ul_nomg;
PP(pp_i_subtract)
{
- dVAR; dSP; dATARGET;
+ dSP; dATARGET;
tryAMAGICbin_MG(subtr_amg, AMGf_assign);
{
dPOPTOPiirl_ul_nomg;
PP(pp_i_lt)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(lt_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_gt)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(gt_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_le)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(le_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_ge)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(ge_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_eq)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(eq_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_ne)
{
- dVAR; dSP;
+ dSP;
tryAMAGICbin_MG(ne_amg, AMGf_set);
{
dPOPTOPiirl_nomg;
PP(pp_i_ncmp)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICbin_MG(ncmp_amg, 0);
{
dPOPTOPiirl_nomg;
PP(pp_i_negate)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(neg_amg, 0);
if (S_negate_string(aTHX)) return NORMAL;
{
PP(pp_atan2)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICbin_MG(atan2_amg, 0);
{
dPOPTOPnnrl_nomg;
PP(pp_sin)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
int amg_type = sin_amg;
const char *neg_report = NULL;
NV (*func)(NV) = Perl_sin;
PP(pp_rand)
{
- dVAR;
if (!PL_srand_called) {
(void)seedDrand01((Rand_seed_t)seed());
PL_srand_called = TRUE;
PP(pp_srand)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
UV anum;
if (MAXARG >= 1 && (TOPs || POPs)) {
PP(pp_int)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(int_amg, AMGf_numeric);
{
SV * const sv = TOPs;
PP(pp_abs)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
tryAMAGICun_MG(abs_amg, AMGf_numeric);
{
SV * const sv = TOPs;
PP(pp_oct)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
const char *tmps;
I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
STRLEN len;
PP(pp_length)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV * const sv = TOPs;
SvGETMAGIC(sv);
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;
PP(pp_substr)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV *sv;
STRLEN curlen;
STRLEN utf8_curlen;
PP(pp_vec)
{
- dVAR; dSP;
+ dSP;
const IV size = POPi;
const IV offset = POPi;
SV * const src = POPs;
PP(pp_index)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV *big;
SV *little;
SV *temp = NULL;
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));
PP(pp_ord)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV *argsv = POPs;
STRLEN len;
PP(pp_chr)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
char *tmps;
UV value;
SV *top = POPs;
PP(pp_crypt)
{
#ifdef HAS_CRYPT
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
dPOPTOPssrl;
STRLEN len;
const char *tmps = SvPV_const(left, len);
* 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. */
of the three tight loops. There is less and less commonality though */
PP(pp_uc)
{
- dVAR;
dSP;
SV *source = TOPs;
STRLEN len;
PP(pp_lc)
{
- dVAR;
dSP;
SV *source = TOPs;
STRLEN len;
PP(pp_quotemeta)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV * const sv = TOPs;
STRLEN len;
const char *s = SvPV_const(sv,len);
PP(pp_fc)
{
- dVAR;
dTARGET;
dSP;
SV *source = TOPs;
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);
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;
/* Smart dereferencing for keys, values and each */
PP(pp_rkeys)
{
- dVAR;
dSP;
dPOPss;
PP(pp_aeach)
{
- dVAR;
dSP;
AV *array = MUTABLE_AV(POPs);
const I32 gimme = GIMME_V;
PP(pp_akeys)
{
- dVAR;
dSP;
AV *array = MUTABLE_AV(POPs);
const I32 gimme = GIMME_V;
PP(pp_each)
{
- dVAR;
dSP;
HV * hash = MUTABLE_HV(POPs);
HE *entry;
STATIC OP *
S_do_delete_local(pTHX)
{
- dVAR;
dSP;
const I32 gimme = GIMME_V;
const MAGIC *mg;
PP(pp_delete)
{
- dVAR;
dSP;
I32 gimme;
I32 discard;
PP(pp_exists)
{
- dVAR;
dSP;
SV *tmpsv;
HV *hv;
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;
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;
PP(pp_list)
{
- dVAR;
I32 markidx = POPMARK;
if (GIMME != G_ARRAY) {
SV **mark = PL_stack_base + markidx;
PP(pp_lslice)
{
- dVAR;
dSP;
SV ** const lastrelem = PL_stack_sp;
SV ** const lastlelem = PL_stack_base + POPMARK;
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;
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))
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;
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);
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));
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);
PP(pp_reverse)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
if (GIMME == G_ARRAY) {
if (PL_op->op_private & OPpREVERSE_INPLACE) {
PP(pp_split)
{
- dVAR; dSP; dTARG;
+ dSP; dTARG;
AV *ary;
IV limit = POPi; /* note, negative is forever */
SV * const sv = POPs;
PP(pp_lock)
{
- dVAR;
dSP;
dTOPss;
SV *retsv = sv;
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.
PP(pp_wantarray)
{
- dVAR;
dSP;
I32 cxix;
const PERL_CONTEXT *cx;
PP(pp_regcreset)
{
- dVAR;
TAINT_NOT;
return NORMAL;
}
PP(pp_regcomp)
{
- dVAR;
dSP;
PMOP *pm = (PMOP*)cLOGOP->op_other;
SV **args;
PP(pp_substcont)
{
- dVAR;
dSP;
PERL_CONTEXT *cx = &cxstack[cxstack_ix];
PMOP * const pm = (PMOP*) cLOGOP->op_other;
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);
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 */
}
/* 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();
}
PP(pp_grepstart)
{
- dVAR; dSP;
+ dSP;
SV *src;
if (PL_stack_base + *PL_markstack_ptr == SP) {
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;
PP(pp_range)
{
- dVAR;
if (GIMME == G_ARRAY)
return NORMAL;
if (SvTRUEx(PAD_SV(PL_op->op_targ)))
PP(pp_flip)
{
- dVAR;
dSP;
if (GIMME == G_ARRAY) {
PP(pp_flop)
{
- dVAR; dSP;
+ dSP;
if (GIMME == G_ARRAY) {
dPOPPOPssrl;
STATIC I32
S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
{
- dVAR;
I32 i;
PERL_ARGS_ASSERT_DOPOPTOLABEL;
I32
Perl_dowantarray(pTHX)
{
- dVAR;
const I32 gimme = block_gimme();
return (gimme == G_VOID) ? G_SCALAR : gimme;
}
I32
Perl_block_gimme(pTHX)
{
- dVAR;
const I32 cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
return G_VOID;
I32
Perl_is_lvalue_sub(pTHX)
{
- dVAR;
const I32 cxix = dopoptosub(cxstack_ix);
assert(cxix >= 0); /* We should only be called from inside subs */
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 */
STATIC I32
S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
{
- dVAR;
I32 i;
PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
STATIC I32
S_dopoptoeval(pTHX_ I32 startingblock)
{
- dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
const PERL_CONTEXT *cx = &cxstack[i];
STATIC I32
S_dopoptoloop(pTHX_ I32 startingblock)
{
- dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
const PERL_CONTEXT * const cx = &cxstack[i];
STATIC I32
S_dopoptogiven(pTHX_ I32 startingblock)
{
- dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
const PERL_CONTEXT *cx = &cxstack[i];
STATIC I32
S_dopoptowhen(pTHX_ I32 startingblock)
{
- dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
const PERL_CONTEXT *cx = &cxstack[i];
void
Perl_dounwind(pTHX_ I32 cxix)
{
- dVAR;
I32 optype;
if (!PL_curstackinfo) /* can happen if die during thread cloning */
void
Perl_qerror(pTHX_ SV *err)
{
- dVAR;
-
PERL_ARGS_ASSERT_QERROR;
if (PL_in_eval) {
void
Perl_die_unwind(pTHX_ SV *msv)
{
- dVAR;
SV *exceptsv = sv_mortalcopy(msv);
U8 in_eval = PL_in_eval;
PERL_ARGS_ASSERT_DIE_UNWIND;
PP(pp_xor)
{
- dVAR; dSP; dPOPTOPssrl;
+ dSP; dPOPTOPssrl;
if (SvTRUE(left) != SvTRUE(right))
RETSETYES;
else
PP(pp_caller)
{
- dVAR;
dSP;
const PERL_CONTEXT *cx;
const PERL_CONTEXT *dbcx;
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;
PP(pp_reset)
{
- dVAR;
dSP;
const char * tmps;
STRLEN len = 0;
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;
PP(pp_enter)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
PP(pp_leave)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
SV **newsp;
PMOP *newpm;
PP(pp_enteriter)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
void *itervar; /* location of the iteration variable */
PP(pp_enterloop)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
PP(pp_leaveloop)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PP(pp_return)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
PERL_CONTEXT *cx;
bool popsub2 = FALSE;
bool clear_errsv = FALSE;
* pp_return */
PP(pp_leavesublv)
{
- dVAR; dSP;
+ dSP;
SV **newsp;
PMOP *newpm;
I32 gimme;
static I32
S_unwind_loop(pTHX_ const char * const opname)
{
- dVAR;
I32 cxix;
if (PL_op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
PP(pp_last)
{
- dVAR;
PERL_CONTEXT *cx;
I32 pop2 = 0;
I32 gimme;
PP(pp_next)
{
- dVAR;
PERL_CONTEXT *cx;
const I32 inner = PL_scopestack_ix;
PP(pp_redo)
{
- dVAR;
const I32 cxix = S_unwind_loop(aTHX_ "redo");
PERL_CONTEXT *cx;
I32 oldsave;
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";
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;
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) {
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;
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)
PP(pp_exit)
{
- dVAR;
dSP;
I32 anum;
STATIC OP *
S_docatch(pTHX_ OP *o)
{
- dVAR;
int ret;
OP * const oldop = PL_op;
dJMPENV;
CV *
Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
{
- dVAR;
PERL_SI *si;
int level = 0;
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;
PP(pp_require)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
SV *sv;
const char *name;
PP(pp_hintseval)
{
- dVAR;
dSP;
mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
RETURN;
PP(pp_entereval)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
SV *sv;
const I32 gimme = GIMME_V;
PP(pp_leaveeval)
{
- dVAR; dSP;
+ dSP;
SV **newsp;
PMOP *newpm;
I32 gimme;
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);
PP(pp_leavetry)
{
- dVAR; dSP;
+ dSP;
SV **newsp;
PMOP *newpm;
I32 gimme;
PP(pp_entergiven)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
PP(pp_leavegiven)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
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;
STATIC bool
S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
{
- dVAR;
dSP;
PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
STATIC void
S_destroy_matcher(pTHX_ PMOP *matcher)
{
- dVAR;
-
PERL_ARGS_ASSERT_DESTROY_MATCHER;
PERL_UNUSED_ARG(matcher);
STATIC OP *
S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
{
- dVAR;
dSP;
bool object_on_left = FALSE;
PP(pp_enterwhen)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
PP(pp_leavewhen)
{
- dVAR; dSP;
+ dSP;
I32 cxix;
PERL_CONTEXT *cx;
I32 gimme;
PP(pp_continue)
{
- dVAR; dSP;
+ dSP;
I32 cxix;
PERL_CONTEXT *cx;
I32 gimme;
PP(pp_break)
{
- dVAR;
I32 cxix;
PERL_CONTEXT *cx;
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));
PP(pp_const)
{
- dVAR;
dSP;
XPUSHs(cSVOP_sv);
RETURN;
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;
PP(pp_gvsv)
{
- dVAR;
dSP;
EXTEND(SP,1);
if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
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);
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
PP(pp_sassign)
{
- dVAR; dSP;
+ dSP;
/* sassign keeps its args in the optree traditionally backwards.
So we pop them differently.
*/
PP(pp_cond_expr)
{
- dVAR; dSP;
+ dSP;
PERL_ASYNC_CHECK();
if (SvTRUEx(POPs))
RETURNOP(cLOGOP->op_other);
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;
PP(pp_concat)
{
- dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
+ dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
{
dPOPTOPssrl;
bool lbyte;
PP(pp_padrange)
{
- dVAR; dSP;
+ dSP;
PADOFFSET base = PL_op->op_targ;
int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
int i;
PP(pp_padsv)
{
- dVAR; dSP;
+ dSP;
EXTEND(SP, 1);
{
OP * const op = PL_op;
PP(pp_readline)
{
- dVAR;
dSP;
if (TOPs) {
SvGETMAGIC(TOPs);
PP(pp_eq)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
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))))
PP(pp_or)
{
- dVAR; dSP;
+ dSP;
PERL_ASYNC_CHECK();
if (SvTRUE(TOPs))
RETURN;
PP(pp_defined)
{
- dVAR; dSP;
+ dSP;
SV* sv;
bool defined;
const int op_type = PL_op->op_type;
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;
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;
PP(pp_join)
{
- dVAR; dSP; dMARK; dTARGET;
+ dSP; dMARK; dTARGET;
MARK++;
do_join(TARG, *MARK, MARK, SP);
SP = MARK;
PP(pp_pushre)
{
- dVAR; dSP;
+ dSP;
#ifdef DEBUGGING
/*
* We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
PP(pp_print)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
PerlIO *fp;
MAGIC *mg;
GV * const gv
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";
STATIC void
S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
{
- dVAR;
-
PERL_ARGS_ASSERT_DO_ODDBALL;
if (*oddkey) {
PP(pp_qr)
{
- dVAR; dSP;
+ dSP;
PMOP * const pm = cPMOP;
REGEXP * rx = PM_GETRE(pm);
SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
PP(pp_match)
{
- dVAR; dSP; dTARG;
+ dSP; dTARG;
PMOP *pm = cPMOP;
PMOP *dynpm = pm;
const char *s;
OP *
Perl_do_readline(pTHX)
{
- dVAR; dSP; dTARGETSTACKED;
+ dSP; dTARGETSTACKED;
SV *sv;
STRLEN tmplen = 0;
STRLEN offset;
PP(pp_helem)
{
- dVAR; dSP;
+ dSP;
HE* he;
SV **svp;
SV * const keysv = POPs;
PP(pp_iter)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
SV *oldsv;
SV **itersvp;
PP(pp_subst)
{
- dVAR; dSP; dTARG;
+ dSP; dTARG;
PMOP *pm = cPMOP;
PMOP *rpm = pm;
char *s;
PP(pp_grepwhile)
{
- dVAR; dSP;
+ dSP;
if (SvTRUEx(POPs))
PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
PP(pp_leavesub)
{
- dVAR; dSP;
+ dSP;
SV **mark;
SV **newsp;
PMOP *newpm;
PP(pp_entersub)
{
- dVAR; dSP; dPOPss;
+ dSP; dPOPss;
GV *gv;
CV *cv;
PERL_CONTEXT *cx;
PP(pp_aelem)
{
- dVAR; dSP;
+ dSP;
SV** svp;
SV* const elemsv = POPs;
IV elem = SvIV(elemsv);
PP(pp_method)
{
- dVAR; dSP;
+ dSP;
SV* const sv = TOPs;
if (SvROK(sv)) {
PP(pp_method_named)
{
- dVAR; dSP;
+ dSP;
SV* const sv = cSVOP_sv;
U32 hash = SvSHARED_HASH(sv);
STATIC SV *
S_method_common(pTHX_ SV* meth, U32* hashp)
{
- dVAR;
SV* ob;
GV* gv;
HV* stash;
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) ||
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;
PP(pp_unpack)
{
- dVAR;
dSP;
dPOPPOPssrl;
I32 gimme = GIMME_V;
void
Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist )
{
- dVAR;
tempsym_t sym;
PERL_ARGS_ASSERT_PACKLIST;
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);
PP(pp_pack)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
SV *cat = TARG;
STRLEN fromlen;
SV *pat_sv = *++MARK;
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;
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);
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);
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;
PP(pp_sort)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
SV **p1 = ORIGMARK+1, **p2;
SSize_t max, i;
AV* av = NULL;
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;
}
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;
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;
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);
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;
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;
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;
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;
PP(pp_backtick)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
PerlIO *fp;
const char * const tmps = POPpconstx;
const I32 gimme = GIMME_V;
PP(pp_glob)
{
- dVAR;
OP *result;
dSP;
GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
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) {
PP(pp_die)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
SV *exsv;
STRLEN len;
#ifdef VMS
PP(pp_open)
{
- dVAR; dSP;
+ dSP;
dMARK; dORIGMARK;
dTARGET;
SV *sv;
PP(pp_close)
{
- dVAR; dSP;
+ dSP;
GV * const gv =
MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
PP(pp_pipe_op)
{
#ifdef HAS_PIPE
- dVAR;
dSP;
IO *rstio;
IO *wstio;
PP(pp_fileno)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
GV *gv;
IO *io;
PerlIO *fp;
PP(pp_umask)
{
- dVAR;
dSP;
#ifdef HAS_UMASK
dTARGET;
PP(pp_binmode)
{
- dVAR; dSP;
+ dSP;
GV *gv;
IO *io;
PerlIO *fp;
PP(pp_tie)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
HV* stash;
GV *gv = NULL;
SV *sv;
PP(pp_untie)
{
- dVAR; dSP;
+ dSP;
MAGIC *mg;
SV *sv = POPs;
const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
PP(pp_tied)
{
- dVAR;
dSP;
const MAGIC *mg;
dTOPss;
PP(pp_dbmopen)
{
- dVAR; dSP;
+ dSP;
dPOPPOPssrl;
HV* stash;
GV *gv = NULL;
PP(pp_sselect)
{
#ifdef HAS_SELECT
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
I32 i;
I32 j;
char *s;
void
Perl_setdefout(pTHX_ GV *gv)
{
- dVAR;
PERL_ARGS_ASSERT_SETDEFOUT;
SvREFCNT_inc_simple_void_NN(gv);
SvREFCNT_dec(PL_defoutgv);
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);
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);
STATIC OP *
S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
{
- dVAR;
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
PP(pp_enterwrite)
{
- dVAR;
dSP;
GV *gv;
IO *io;
PP(pp_leavewrite)
{
- dVAR; dSP;
+ dSP;
GV * const gv = cxstack[cxstack_ix].blk_format.gv;
IO * const io = GvIOp(gv);
PerlIO *ofp;
PP(pp_prtf)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
PerlIO *fp;
GV * const gv
PP(pp_sysopen)
{
- dVAR;
dSP;
const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
const int mode = POPi;
PP(pp_sysread)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
SSize_t offset;
IO *io;
char *buffer;
PP(pp_syswrite)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
SV *bufsv;
const char *buffer;
SSize_t retval;
PP(pp_eof)
{
- dVAR; dSP;
+ dSP;
GV *gv;
IO *io;
const MAGIC *mg;
PP(pp_tell)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
GV *gv;
IO *io;
PP(pp_sysseek)
{
- dVAR; dSP;
+ dSP;
const int whence = POPi;
#if LSEEKSIZE > IVSIZE
const Off_t offset = (Off_t)SvNVx(POPs);
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
PP(pp_ioctl)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV * const argsv = POPs;
const unsigned int func = POPu;
int optype;
PP(pp_flock)
{
#ifdef FLOCK
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
I32 value;
const int argtype = POPi;
GV * const gv = MUTABLE_GV(POPs);
PUSHi(value);
RETURN;
#else
- DIE(aTHX_ PL_no_func, "flock()");
+ DIE(aTHX_ PL_no_func, "flock");
#endif
}
PP(pp_socket)
{
- dVAR; dSP;
+ dSP;
const int protocol = POPi;
const int type = POPi;
const int domain = POPi;
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;
PP(pp_bind)
{
- dVAR; dSP;
+ dSP;
SV * const addrsv = POPs;
/* OK, so on what platform does bind modify addr? */
const char *addr;
PP(pp_listen)
{
- dVAR; dSP;
+ dSP;
const int backlog = POPi;
GV * const gv = MUTABLE_GV(POPs);
IO * const io = GvIOn(gv);
PP(pp_accept)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
IO *nstio;
char namebuf[MAXPATHLEN];
#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
PP(pp_shutdown)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
const int how = POPi;
GV * const gv = MUTABLE_GV(POPs);
IO * const io = GvIOn(gv);
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;
PP(pp_getpeername)
{
- dVAR; dSP;
+ dSP;
const int optype = PL_op->op_type;
GV * const gv = MUTABLE_GV(POPs);
IO * const io = GvIOn(gv);
PP(pp_stat)
{
- dVAR;
dSP;
GV *gv = NULL;
IO *io = NULL;
STATIC OP *
S_try_amagic_ftest(pTHX_ char chr) {
- dVAR;
SV *const arg = *PL_stack_sp;
assert(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 */
PP(pp_ftis)
{
- dVAR;
I32 result;
const int op_type = PL_op->op_type;
char opchar = '?';
PP(pp_ftrowned)
{
- dVAR;
I32 result;
char opchar = '?';
PP(pp_ftlink)
{
- dVAR;
I32 result;
tryAMAGICftest_MG('l');
PP(pp_fttty)
{
- dVAR;
int fd;
GV *gv;
char *name = NULL;
PP(pp_fttext)
{
- dVAR;
I32 i;
SSize_t len;
I32 odd = 0;
PP(pp_chdir)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
const char *tmps = NULL;
GV *gv = NULL;
PP(pp_chown)
{
- dVAR; dSP; dMARK; dTARGET;
+ dSP; dMARK; dTARGET;
const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
SP = MARK;
PP(pp_chroot)
{
#ifdef HAS_CHROOT
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
char * const tmps = POPpx;
TAINT_PROPER("chroot");
PUSHi( chroot(tmps) >= 0 );
PP(pp_rename)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
int anum;
const char * const tmps2 = POPpconstx;
const char * const tmps = SvPV_nolen_const(TOPs);
#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;
PP(pp_readlink)
{
- dVAR;
dSP;
#ifdef HAS_SYMLINK
dTARGET;
PP(pp_mkdir)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
STRLEN len;
const char *tmps;
bool copy = FALSE;
PP(pp_rmdir)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
STRLEN len;
const char *tmps;
bool copy = FALSE;
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);
#if !defined(I_DIRENT) && !defined(VMS)
Direntry_t *readdir (DIR *);
#endif
- dVAR;
dSP;
SV *sv;
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.
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);
PP(pp_rewinddir)
{
#if defined(HAS_REWINDDIR) || defined(rewinddir)
- dVAR; dSP;
+ dSP;
GV * const gv = MUTABLE_GV(POPs);
IO * const io = GvIOn(gv);
PP(pp_closedir)
{
#if defined(Direntry_t) && defined(HAS_READDIR)
- dVAR; dSP;
+ dSP;
GV * const gv = MUTABLE_GV(POPs);
IO * const io = GvIOn(gv);
PP(pp_fork)
{
#ifdef HAS_FORK
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
Pid_t childpid;
#ifdef HAS_SIGPROCMASK
sigset_t oldmask, newmask;
PP(pp_wait)
{
#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
Pid_t childpid;
int argflags;
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;
PP(pp_system)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
#if defined(__LIBCATAMOUNT__)
PL_statusvalue = -1;
SP = ORIGMARK;
PP(pp_exec)
{
- dVAR; dSP; dMARK; dORIGMARK; dTARGET;
+ dSP; dMARK; dORIGMARK; dTARGET;
I32 value;
if (TAINTING_get) {
PP(pp_getppid)
{
#ifdef HAS_GETPPID
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
XPUSHi( getppid() );
RETURN;
#else
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);
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;
#endif /* USE_BSDPGRP */
RETURN;
#else
- DIE(aTHX_ PL_no_func, "setpgrp()");
+ DIE(aTHX_ PL_no_func, "setpgrp");
#endif
}
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;
SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
RETURN;
#else
- DIE(aTHX_ PL_no_func, "setpriority()");
+ DIE(aTHX_ PL_no_func, "setpriority");
#endif
}
PP(pp_time)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
#ifdef BIG_TIME
XPUSHn( time(NULL) );
#else
PP(pp_tms)
{
#ifdef HAS_TIMES
- dVAR;
dSP;
struct tms timesbuf;
PP(pp_gmtime)
{
- dVAR;
dSP;
Time64_T when;
struct TM tmbuf;
PP(pp_alarm)
{
#ifdef HAS_ALARM
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
int anum;
anum = POPi;
anum = alarm((unsigned int)anum);
PP(pp_sleep)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
I32 duration;
Time_t lasttime;
Time_t when;
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;
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)
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)
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;
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? */
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? */
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? */
PP(pp_shostent)
{
- dVAR; dSP;
+ dSP;
const int stayopen = TOPi;
switch(PL_op->op_type) {
case OP_SHOSTENT:
PP(pp_ehostent)
{
- dVAR; dSP;
+ dSP;
switch(PL_op->op_type) {
case OP_EHOSTENT:
#ifdef HAS_ENDHOSTENT
PP(pp_gpwent)
{
#ifdef HAS_PASSWD
- dVAR; dSP;
+ dSP;
I32 which = PL_op->op_type;
SV *sv;
struct passwd *pwent = NULL;
PP(pp_ggrent)
{
#ifdef HAS_GROUP
- dVAR; dSP;
+ dSP;
const I32 which = PL_op->op_type;
const struct group *grent;
PP(pp_getlogin)
{
#ifdef HAS_GETLOGIN
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
char *tmps;
EXTEND(SP, 1);
if (!(tmps = PerlProc_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;
#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)
#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)
#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)
#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)
#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)
#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)
#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)
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__;
#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)
#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)
#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)
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)
#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 \
#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)
#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);
#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)
void
Perl_reentrant_size(pTHX) {
+ PERL_UNUSED_CONTEXT;
#ifdef USE_REENTRANT_API
#define REENTRANTSMALLSIZE 256 /* Make something up. */
#define REENTRANTUSUALSIZE 4096 /* Make something up. */
void
Perl_reentrant_init(pTHX) {
+ PERL_UNUSED_CONTEXT;
#ifdef USE_REENTRANT_API
Newx(PL_reentrant_buffer, 1, REENTR);
Perl_reentrant_size(aTHX);
void
Perl_reentrant_free(pTHX) {
+ PERL_UNUSED_CONTEXT;
#ifdef USE_REENTRANT_API
#ifdef HAS_ASCTIME_R
Safefree(PL_reentrant_buffer->_asctime_buffer);
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;
/* 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;
void
Perl_reginitcolors(pTHX)
{
- dVAR;
const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
if (s) {
char *t = savepv(s);
regexp_engine const *
Perl_current_re_engine(pTHX)
{
- dVAR;
-
if (IN_PERL_COMPILETIME) {
HV * const table = GvHV(PL_hintgv);
SV **ptr;
REGEXP *
Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
{
- dVAR;
regexp_engine const *eng = current_re_engine();
GET_RE_DEBUG_FLAGS_DECL;
if (oplist) {
assert(oplist->op_type == OP_PADAV
|| oplist->op_type == OP_RV2AV);
- oplist = oplist->op_sibling;;
+ oplist = OP_SIBLING(oplist);
}
if (SvRMAGICAL(av)) {
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 */
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;
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) {
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++;
}
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;
}
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,
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)
* 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;
STATIC regnode *
S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
{
- dVAR;
regnode *ret;
regnode *chain = NULL;
regnode *latest;
STATIC regnode *
S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
{
- dVAR;
regnode *ret;
char op;
char *next;
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;
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);
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;
* 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
PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
+ assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
+
switch (cp) {
case 'k':
case 'K':
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 */
* 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;
{
PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
- assert(*p = '#');
+ assert(*p == '#');
while (p < RExC_end) {
if (*(++p) == '\n') {
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;
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;
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);
STATIC void
S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
{
- dVAR;
regnode *src;
regnode *dst;
regnode *place;
S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p,
const regnode *val,U32 depth)
{
- dVAR;
regnode *scan;
GET_RE_DEBUG_FLAGS_DECL;
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;
void
Perl_pregfree2(pTHX_ REGEXP *rx)
{
- dVAR;
struct regexp *const r = ReANY(rx);
GET_RE_DEBUG_FLAGS_DECL;
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;
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;
/* 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;
regnode *
Perl_regnext(pTHX_ regnode *p)
{
- dVAR;
I32 offset;
if (!p)
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);
{
/* 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;
}
}
I32
Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
{
- dVAR;
-
PERL_ARGS_ASSERT_KEYWORD;
$switch
void
Perl_reentrant_size(pTHX) {
+ PERL_UNUSED_CONTEXT;
#ifdef USE_REENTRANT_API
#define REENTRANTSMALLSIZE 256 /* Make something up. */
#define REENTRANTUSUALSIZE 4096 /* Make something up. */
void
Perl_reentrant_init(pTHX) {
+ PERL_UNUSED_CONTEXT;
#ifdef USE_REENTRANT_API
Newx(PL_reentrant_buffer, 1, REENTR);
Perl_reentrant_size(aTHX);
void
Perl_reentrant_free(pTHX) {
+ PERL_UNUSED_CONTEXT;
#ifdef USE_REENTRANT_API
@free
Safefree(PL_reentrant_buffer);
[ 5.021, DEFAULT_ON ],
}],
+ 'missing' => [ 5.021, DEFAULT_OFF],
+ 'redundant' => [ 5.021, DEFAULT_OFF],
+
#'default' => [ 5.008, DEFAULT_ON ],
}],
} ;
__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.
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<warning, fatal>
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;
STATIC void
S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p)
{
- dVAR;
UV i;
U32 paren;
GET_RE_DEBUG_FLAGS_DECL;
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! */
} \
} 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; \
} \
} 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)
}
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),
/* flags: For optimizations. See REXEC_* in regexp.h */
{
- dVAR;
struct regexp *const prog = ReANY(rx);
char *s;
regnode *c;
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);
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) {
{
/* 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;
/* 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))
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 */
* 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;
* '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) {
STATIC U8 *
S_reghop4(U8 *s, SSize_t off, const U8* llim, const U8* rlim)
{
- dVAR;
-
PERL_ARGS_ASSERT_REGHOP4;
if (off >= 0) {
STATIC U8 *
S_reghopmaybe3(U8* s, SSize_t off, const U8* lim)
{
- dVAR;
-
PERL_ARGS_ASSERT_REGHOPMAYBE3;
if (off >= 0) {
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;
/* 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;
int
Perl_runops_standard(pTHX)
{
- dVAR;
OP *op = PL_op;
OP_ENTRY_PROBE(OP_NAME(op));
while ((PL_op = op = op->op_ppaddr(aTHX))) {
SV**
Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n)
{
- dVAR;
-
PERL_ARGS_ASSERT_STACK_GROW;
PL_stack_sp = sp;
PERL_SI *
Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
{
- dVAR;
PERL_SI *si;
Newx(si, 1, PERL_SI);
si->si_stack = newAV();
I32
Perl_cxinc(pTHX)
{
- dVAR;
const IV old_max = cxstack_max;
cxstack_max = GROW(cxstack_max);
Renew(cxstack, cxstack_max + 1, PERL_CONTEXT);
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);
void
Perl_pop_scope(pTHX)
{
- dVAR;
const I32 oldsave = PL_scopestack[--PL_scopestack_ix];
LEAVE_SCOPE(oldsave);
}
I32 *
Perl_markstack_grow(pTHX)
{
- dVAR;
const I32 oldmax = PL_markstack_max - PL_markstack;
const I32 newmax = GROW(oldmax);
void
Perl_savestack_grow(pTHX)
{
- dVAR;
PL_savestack_max = GROW(PL_savestack_max) + 4;
Renew(PL_savestack, PL_savestack_max, ANY);
}
void
Perl_savestack_grow_cnt(pTHX_ I32 need)
{
- dVAR;
PL_savestack_max = PL_savestack_ix + need;
Renew(PL_savestack, PL_savestack_max, ANY);
}
void
Perl_tmps_grow(pTHX_ SSize_t n)
{
- dVAR;
#ifndef STRESS_REALLOC
if (n < 128)
n = (PL_tmps_max < 512) ? 128 : 512;
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 */
STATIC SV *
S_save_scalar_at(pTHX_ SV **sptr, const U32 flags)
{
- dVAR;
SV * osv;
SV *sv;
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);
SV *
Perl_save_scalar(pTHX_ GV *gv)
{
- dVAR;
SV ** const sptr = &GvSVn(gv);
PERL_ARGS_ASSERT_SAVE_SCALAR;
void
Perl_save_generic_svref(pTHX_ SV **sptr)
{
- dVAR;
-
PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF;
save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_GENERIC_SVREF);
void
Perl_save_generic_pvref(pTHX_ char **str)
{
- dVAR;
-
PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF;
save_pushptrptr(*str, str, SAVEt_GENERIC_PVREF);
void
Perl_save_shared_pvref(pTHX_ char **str)
{
- dVAR;
-
PERL_ARGS_ASSERT_SAVE_SHARED_PVREF;
save_pushptrptr(str, *str, SAVEt_SHARED_PVREF);
void
Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val)
{
- dVAR;
dSS_ADD;
PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS;
void
Perl_save_gp(pTHX_ GV *gv, I32 empty)
{
- dVAR;
-
PERL_ARGS_ASSERT_SAVE_GP;
save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP);
AV *
Perl_save_ary(pTHX_ GV *gv)
{
- dVAR;
AV * const oav = GvAVn(gv);
AV *av;
HV *
Perl_save_hash(pTHX_ GV *gv)
{
- dVAR;
HV *ohv, *hv;
PERL_ARGS_ASSERT_SAVE_HASH;
void
Perl_save_item(pTHX_ SV *item)
{
- dVAR;
SV * const sv = newSVsv(item);
PERL_ARGS_ASSERT_SAVE_ITEM;
void
Perl_save_bool(pTHX_ bool *boolp)
{
- dVAR;
dSS_ADD;
PERL_ARGS_ASSERT_SAVE_BOOL;
void
Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type)
{
- dVAR;
dSS_ADD;
SS_ADD_INT(i);
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;
void
Perl_save_I8(pTHX_ I8 *bytep)
{
- dVAR;
dSS_ADD;
PERL_ARGS_ASSERT_SAVE_I8;
void
Perl_save_I16(pTHX_ I16 *intp)
{
- dVAR;
dSS_ADD;
PERL_ARGS_ASSERT_SAVE_I16;
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;
void
Perl_save_strlen(pTHX_ STRLEN *ptr)
{
- dVAR;
dSS_ADD;
PERL_ARGS_ASSERT_SAVE_STRLEN;
void
Perl_save_pptr(pTHX_ char **pptr)
{
- dVAR;
-
PERL_ARGS_ASSERT_SAVE_PPTR;
save_pushptrptr(*pptr, pptr, SAVEt_PPTR);
void
Perl_save_vptr(pTHX_ void *ptr)
{
- dVAR;
-
PERL_ARGS_ASSERT_SAVE_VPTR;
save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR);
void
Perl_save_sptr(pTHX_ SV **sptr)
{
- dVAR;
-
PERL_ARGS_ASSERT_SAVE_SPTR;
save_pushptrptr(*sptr, sptr, SAVEt_SPTR);
void
Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)
{
- dVAR;
dSS_ADD;
ASSERT_CURPAD_ACTIVE("save_padsv");
void
Perl_save_hptr(pTHX_ HV **hptr)
{
- dVAR;
-
PERL_ARGS_ASSERT_SAVE_HPTR;
save_pushptrptr(*hptr, hptr, SAVEt_HPTR);
void
Perl_save_aptr(pTHX_ AV **aptr)
{
- dVAR;
-
PERL_ARGS_ASSERT_SAVE_APTR;
save_pushptrptr(*aptr, aptr, SAVEt_APTR);
void
Perl_save_pushptr(pTHX_ void *const ptr, const int type)
{
- dVAR;
dSS_ADD;
SS_ADD_PTR(ptr);
SS_ADD_UV(type);
void
Perl_save_clearsv(pTHX_ SV **svp)
{
- dVAR;
const UV offset = svp - PL_curpad;
const UV offset_shifted = offset << SAVE_TIGHT_SHIFT;
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);
void
Perl_save_adelete(pTHX_ AV *av, SSize_t key)
{
- dVAR;
dSS_ADD;
PERL_ARGS_ASSERT_SAVE_ADELETE;
void
Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
{
- dVAR;
dSS_ADD;
-
PERL_ARGS_ASSERT_SAVE_DESTRUCTOR;
SS_ADD_DPTR(f);
void
Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
{
- dVAR;
dSS_ADD;
SS_ADD_DXPTR(f);
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);
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;
void
Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
{
- dVAR;
SV *sv;
PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS;
SV*
Perl_save_svref(pTHX_ SV **sptr)
{
- dVAR;
-
PERL_ARGS_ASSERT_SAVE_SVREF;
SvGETMAGIC(*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));
void
Perl_leave_scope(pTHX_ I32 base)
{
- dVAR;
-
/* Localise the effects of the TAINT_NOT inside the loop. */
bool was = TAINT_get;
void
Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
{
- dVAR;
-
PERL_ARGS_ASSERT_CX_DUMP;
#ifdef DEBUGGING
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() */
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;
STATIC I32
S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
{
- dVAR;
SV* sva;
I32 visited = 0;
static void
do_clean_objs(pTHX_ SV *const ref)
{
- dVAR;
assert (SvROK(ref));
{
SV * const target = SvRV(ref);
static void
do_clean_named_objs(pTHX_ SV *const sv)
{
- dVAR;
SV *obj;
assert(SvTYPE(sv) == SVt_PVGV);
assert(isGV_with_GP(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));
void
Perl_sv_clean_objs(pTHX)
{
- dVAR;
GV *olddef, *olderr;
PL_in_clean_objs = TRUE;
visit(do_clean_objs, SVf_ROK, SVf_ROK);
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;
I32
Perl_sv_clean_all(pTHX)
{
- dVAR;
I32 cleaned;
PL_in_clean_all = TRUE;
cleaned = visit(do_clean_all, 0,0);
void
Perl_sv_free_arenas(pTHX)
{
- dVAR;
SV* sva;
SV* svanext;
unsigned int i;
=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
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;
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;
STATIC void *
S_new_body(pTHX_ const svtype sv_type)
{
- dVAR;
void *xpv;
new_body_inline(xpv, sv_type);
return xpv;
void
Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
{
- dVAR;
void* old_body;
void* new_body;
const svtype old_type = SvTYPE(sv);
*/
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);
void
Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_SETIV;
SV_CHECK_THINKFIRST_COW_DROP(sv);
void
Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_SETNV;
SV_CHECK_THINKFIRST_COW_DROP(sv);
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 */
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 */
"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
# 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) {
STATIC bool
S_sv_2iuv_common(pTHX_ SV *const sv)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2IUV_COMMON;
if (SvNOKp(sv)) {
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
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))
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
char *
Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
{
- dVAR;
char *s;
PERL_ARGS_ASSERT_SV_2PV_FLAGS;
bool
Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
restart:
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)
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)) {
void
Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
{
- dVAR;
U32 sflags;
int dtype;
svtype stype;
void
Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
{
- dVAR;
char *dptr;
PERL_ARGS_ASSERT_SV_SETPVN;
void
Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
{
- dVAR;
STRLEN len;
PERL_ARGS_ASSERT_SV_SETPV;
void
Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_SETHEK;
if (!hek) {
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;
static void
S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
{
- dVAR;
-
assert(SvIsCOW(sv));
{
#ifdef PERL_ANY_COW
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);
void
Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
if (ssv) {
void
Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
{
- dVAR;
STRLEN len;
STRLEN tlen;
char *junk;
SV *
Perl_newSV(pTHX_ const STRLEN len)
{
- dVAR;
SV *sv;
new_SV(sv);
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;
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;
void
Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
{
- dVAR;
SV **svp;
AV *av = NULL;
MAGIC *mg = NULL;
void
Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
{
- dVAR;
SV **svp = NULL;
PERL_ARGS_ASSERT_SV_DEL_BACKREF;
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;
void
Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
{
- dVAR;
const U32 refcnt = SvREFCNT(sv);
PERL_ARGS_ASSERT_SV_REPLACE;
static bool
S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
- dVAR;
-
PERL_ARGS_ASSERT_CURSE;
assert(SvOBJECT(sv));
STRLEN
Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
{
- dVAR;
STRLEN len;
const U8 *s = (U8*)SvPV_nomg_const(sv, len);
I32
Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
{
- dVAR;
const char *pv1;
STRLEN cur1;
const char *pv2;
Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2,
const U32 flags)
{
- dVAR;
STRLEN cur1, cur2;
const char *pv1, *pv2;
I32 cmp;
Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2,
const U32 flags)
{
- dVAR;
#ifdef USE_LOCALE_COLLATE
char *pv1, *pv2;
char *
Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
{
- dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
char *
Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
{
- dVAR;
const char *rsptr;
STRLEN rslen;
STDCHAR rslast;
void
Perl_sv_inc_nomg(pTHX_ SV *const sv)
{
- dVAR;
char *d;
int flags;
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.
#endif
}
#endif /* PERL_PRESERVE_IVUV */
+ if (!numtype && ckWARN(WARN_NUMERIC))
+ not_incrementable(sv);
sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
return;
}
void
Perl_sv_dec(pTHX_ SV *const sv)
{
- dVAR;
if (!sv)
return;
SvGETMAGIC(sv);
void
Perl_sv_dec_nomg(pTHX_ SV *const sv)
{
- dVAR;
int flags;
if (!sv)
SV *
Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags)
{
- dVAR;
SV *sv;
if (flags & SV_GMAGIC)
SV *
Perl_sv_newmortal(pTHX)
{
- dVAR;
SV *sv;
new_SV(sv);
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.
SV *
Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
{
- dVAR;
SV *sv;
new_SV(sv);
SV *
Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
{
- dVAR;
SV *sv;
-
new_SV(sv);
sv_setpvn(sv,buffer,len);
return sv;
SV *
Perl_newSVhek(pTHX_ const HEK *const hek)
{
- dVAR;
if (!hek) {
SV *sv;
SV *
Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
{
- dVAR;
SV *sv;
PERL_ARGS_ASSERT_VNEWSVPVF;
SV *
Perl_newSVnv(pTHX_ const NV n)
{
- dVAR;
SV *sv;
new_SV(sv);
SV *
Perl_newSViv(pTHX_ const IV i)
{
- dVAR;
SV *sv;
new_SV(sv);
SV *
Perl_newSVuv(pTHX_ const UV u)
{
- dVAR;
SV *sv;
new_SV(sv);
SV *
Perl_newRV_noinc(pTHX_ SV *const tmpRef)
{
- dVAR;
SV *sv = newSV_type(SVt_IV);
PERL_ARGS_ASSERT_NEWRV_NOINC;
SV *
Perl_newRV(pTHX_ SV *const sv)
{
- dVAR;
-
PERL_ARGS_ASSERT_NEWRV;
return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
SV *
Perl_newSVsv(pTHX_ SV *const old)
{
- dVAR;
SV *sv;
if (!old)
void
Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash)
{
- dVAR;
char todo[PERL_UCHAR_MAX+1];
const char *send;
CV *
Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
{
- dVAR;
GV *gv = NULL;
CV *cv = NULL;
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);
SV*
Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
{
- dVAR;
SV *sv;
PERL_ARGS_ASSERT_NEWSVRV;
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) {
SV*
Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
{
- dVAR;
SV *tmpRef;
HV *oldstash = NULL;
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();
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);
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);
* 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)) {
STATIC I32
S_expect_number(pTHX_ char **const pattern)
{
- dVAR;
I32 var = 0;
PERL_ARGS_ASSERT_EXPECT_NUMBER;
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;
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;
(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);
}
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;
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') {
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;
}
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
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)) {
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;
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) ||
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; */
&&
( 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;
* 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))
sv = find_uninit_var(o, uninit_sv, 1);
if (sv)
return sv;
- o = o->op_sibling;
+ o = OP_SIBLING(o);
}
break;
}
void
Perl_report_uninit(pTHX_ const SV *uninit_sv)
{
- dVAR;
if (PL_op) {
SV* varname = NULL;
if (uninit_sv && PL_curpad) {
print F chr(0x100);
close(F);
- like( $@, 'Wide character in print' );
+ like( $@, qr/Wide character in print/ );
undef $@;
open F, ">:utf8", $a_file;
print F chr(0x100);
close(F);
- like( $@, 'Wide character in print' );
+ like( $@, qr/Wide character in print/ );
}
{
$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/;
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" );
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.
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;
$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";
$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";
}
$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";
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";
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
# 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";
}
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";
}
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 }
# 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//
# 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";
# 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";
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';
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' )};
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");
}
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");
}
require './test.pl';
}
-plan(tests => 130);
+plan(tests => 132);
eval 'pass();';
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.
$_ = ${qr //};
$_--;
is($_, -1, 'regexp--');
-$_ = ${qr //};
-$_++;
-is($_, 1, 'regexp++');
+{
+ no warnings 'numeric';
+ $_ = ${qr //};
+ $_++;
+ is($_, 1, 'regexp++');
+}
$_ = v97;
$_++;
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
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)");
}
}
*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");
}
# 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' ); };
$_ = 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 {
# TARG. Test that we respect SvREADONLY.
use constant roref => \2;
eval { for (roref) { $_ = <FH> } };
-like($@, 'Modification of a read-only value attempted', '[perl #19566]');
+like($@, qr/Modification of a read-only value attempted/, '[perl #19566]');
# [perl #21628]
{
{
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" );
}
$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 {
# 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<
>%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<
>%.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<
>%-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<
>%#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<
>%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<
>% 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<
>%#+.*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<
>%#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<
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;
# 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),
);
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;
}
# 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 )] ],
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");
+ }
}
}
}
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}";
'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");
+}
--- /dev/null
+#!/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();
sub run_tests {
{
+ no warnings 'deprecated';
+
my $message = '\C matches octet';
$_ = "a\x{100}b";
ok(/(.)(\C)(\C)(.)/, $message);
}
{
+ no warnings 'deprecated';
+
my $message = '\C matches octet';
$_ = "\x{100}";
ok(/(\C)/g, $message);
}
{
+ no warnings 'deprecated';
+
my $message = '. matches \n with /s';
my $str1 = "foo\nbar";
my $str2 = "foo\n\x{100}bar";
=~ /^(\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);
$& 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/ &&
{ # 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/,
{ # 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(?<foo>)}',
- 'Quantifier unexpected on zero-length expression',
+ qr/Quantifier unexpected on zero-length expression/,
{},
'No segfault on qr{(?&foo){0}abc(?<foo>)}');
}
}
{
+ 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);
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');
# 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
\By\b xy y - -
\by\B yz y - -
\By\B xyz y - -
+\B y - -
\w a y - -
\w - n - -
\W a n - -
(?=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
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");
@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;
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');
+}
+
+}
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;
}
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;
}
-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 }
}
} else {
my %plan = @_;
+ $plan{skip_all} and skip_all($plan{skip_all});
$n = $plan{tests};
}
_print "1..$n\n" unless $noplan;
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;
--- /dev/null
+#!/usr/bin/env perl -w
+use strict;
+use warnings;
+
+BEGIN { require "test.pl"; }
+
+plan skip_all => "Test Test::More compatible plan skip_all => \$foo";
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 }
# TARG. Test that we respect SvREADONLY.
use constant roref=>\2;
eval { for (roref) { $_ = <Fʜ> } };
-like($@, 'Modification of a read-only value attempted', '[perl #19566]');
+like($@, qr/Modification of a read-only value attempted/, '[perl #19566]');
# [perl #21628]
{
void
Perl_taint_env(pTHX)
{
- dVAR;
SV** svp;
MAGIC* mg;
const char* const *e;
#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);
#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);
STATIC int
S_ao(pTHX_ int toketype)
{
- dVAR;
if (*PL_bufptr == '=') {
PL_bufptr++;
if (toketype == ANDAND)
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);
STATIC void
S_missingterm(pTHX_ char *s)
{
- dVAR;
char tmpbuf[3];
char q;
if (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;
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)
STATIC void
S_incline(pTHX_ const char *s)
{
- dVAR;
const char *t;
const char *n;
const char *e;
STATIC void
S_check_uni(pTHX)
{
- dVAR;
const char *s;
const char *t;
STATIC I32
S_lop(pTHX_ I32 f, int x, char *s)
{
- dVAR;
-
PERL_ARGS_ASSERT_LOP;
pl_yylval.ival = f;
STATIC void
S_force_next(pTHX_ I32 type)
{
- dVAR;
#ifdef DEBUGGING
if (DEBUG_T_TEST) {
PerlIO_printf(Perl_debug_log, "### forced token:\n");
static int
S_postderef(pTHX_ int const funny, char const next)
{
- dVAR;
assert(funny == DOLSHARP || strchr("$@%&*", funny));
assert(strchr("*[{", next));
if (next == '*') {
STATIC SV *
S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
{
- dVAR;
SV * const sv = newSVpvn_utf8(start, len,
!IN_BYTES
&& UTF
STATIC char *
S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
{
- dVAR;
char *s;
STRLEN len;
STATIC void
S_force_ident(pTHX_ const char *s, int kind)
{
- dVAR;
-
PERL_ARGS_ASSERT_FORCE_IDENT;
if (s[0]) {
STATIC char *
S_force_version(pTHX_ char *s, int guessing)
{
- dVAR;
OP *version = NULL;
char *d;
STATIC char *
S_force_strict_version(pTHX_ char *s)
{
- dVAR;
OP *version = NULL;
const char *errstr = NULL;
STATIC SV *
S_tokeq(pTHX_ SV *sv)
{
- dVAR;
char *s;
char *send;
char *d;
STATIC I32
S_sublex_start(pTHX)
{
- dVAR;
const I32 op_type = pl_yylval.ival;
if (op_type == OP_NULL) {
STATIC I32
S_sublex_push(pTHX)
{
- dVAR;
LEXSHARED *shared;
const bool is_heredoc = PL_multi_close == '<';
ENTER;
STATIC I32
S_sublex_done(pTHX)
{
- dVAR;
if (!PL_lex_starts++) {
SV * const sv = newSVpvs("");
if (SvUTF8(PL_linestr))
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
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. */
}
#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))))
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++;
STATIC int
S_intuit_more(pTHX_ char *s)
{
- dVAR;
-
PERL_ARGS_ASSERT_INTUIT_MORE;
if (PL_lex_brackets)
STATIC int
S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
{
- dVAR;
char *s = start + (*start == '$');
char tmpbuf[sizeof PL_tokenbuf];
STRLEN len;
SV *
Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
{
- dVAR;
if (!funcp)
return NULL;
void
Perl_filter_del(pTHX_ filter_t funcp)
{
- dVAR;
SV *datasv;
PERL_ARGS_ASSERT_FILTER_DEL;
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.
STATIC char *
S_filter_gets(pTHX_ SV *sv, STRLEN append)
{
- dVAR;
-
PERL_ARGS_ASSERT_FILTER_GETS;
#ifdef PERL_CR_FILTER
STATIC HV *
S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
{
- dVAR;
GV *gv;
PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
STATIC char *
S_tokenize_use(pTHX_ int is_use, char *s) {
- dVAR;
-
PERL_ARGS_ASSERT_TOKENIZE_USE;
if (PL_expect != XSTATE)
: 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;
}
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);
}
}
static int
S_pending_ident(pTHX)
{
- dVAR;
PADOFFSET tmp = 0;
const char pit = (char)pl_yylval.ival;
const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
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 */
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;
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 (;;) {
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);
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++;
STATIC char *
S_scan_pat(pTHX_ char *start, I32 type)
{
- dVAR;
PMOP *pm;
char *s;
const char * const valid_flags =
STATIC char *
S_scan_subst(pTHX_ char *start)
{
- dVAR;
char *s;
PMOP *pm;
I32 first_start;
STATIC char *
S_scan_trans(pTHX_ char *start)
{
- dVAR;
char* s;
OP *o;
U8 squash;
STATIC char *
S_scan_heredoc(pTHX_ char *s)
{
- dVAR;
I32 op_type = OP_SCALAR;
I32 len;
SV *tmpstr;
STATIC char *
S_scan_inputsymbol(pTHX_ char *start)
{
- dVAR;
char *s = start; /* current position in buffer */
char *end;
I32 len;
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 */
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 */
STATIC char *
S_scan_formline(pTHX_ char *s)
{
- dVAR;
char *eol;
char *t;
SV * const stuff = newSVpvs("");
I32
Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
{
- dVAR;
const I32 oldsavestack_ix = PL_savestack_ix;
CV* const outsidecv = PL_compcv;
static int
S_yywarn(pTHX_ const char *const s, U32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_YYWARN;
PL_in_eval |= EVAL_WARNONLY;
int
Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
{
- dVAR;
const char *context = NULL;
int contlen = -1;
SV *msg;
STATIC char*
S_swallow_bom(pTHX_ U8 *s)
{
- dVAR;
const STRLEN slen = SvCUR(PL_linestr);
PERL_ARGS_ASSERT_SWALLOW_BOM;
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. */
char *
Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
{
- dVAR;
const char *pos = s;
const char *start = s;
/*#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 <execinfo.h> 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.
/*#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 <dlfcn.h> 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.
/*#define DIRNAMLEN / **/
#define Direntry_t struct dirent
+/* I_EXECINFO:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <execinfo.h> for backtrace() support.
+ */
+/*#define I_EXECINFO / **/
+
/* I_GRP:
* This symbol, if defined, indicates to the C program that it should
* include <grp.h>.
*/
/*#define I_SYSUIO / **/
+/* I_TERMIO:
+ * This symbol, if defined, indicates that the program should include
+ * <termio.h> rather than <sgtty.h>. 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
+ * <sgtty.h> rather than <termio.h>. 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 <time.h>.
/*#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 <execinfo.h> 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 <execinfo.h> 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 <execinfo.h> for backtrace() support.
- */
-/*#define I_EXECINFO / **/
-
-/* I_TERMIO:
- * This symbol, if defined, indicates that the program should include
- * <termio.h> rather than <sgtty.h>. 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
- * <sgtty.h> rather than <termio.h>. 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.
*/
*/
/*#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.
*/
/*#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 <sys/uio.h>
#endif
/* Generated from:
- * a37f46da5285428077feb313bcbe68661740bac16d76fa658d723d9fcc91c2c4 config_h.SH
+ * 727eb338c23fdd320f556ca32fd7eb5473f68b6ce74db8cec7d83399a2621346 config_h.SH
* 4b709c0b049c660c04c0932eaa8481f9ca6fdc697ec4ffaa86b7bef21ee886a8 uconfig.sh
* ex: set ro: */
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;
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;
XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_isa)
{
- dVAR;
dXSARGS;
if (items != 2)
XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_can)
{
- dVAR;
dXSARGS;
SV *sv;
SV *rv;
else {
pkg = gv_stashsv(sv, 0);
if (!pkg)
- pkg = gv_stashpv("UNIVERSAL", 0);
+ pkg = gv_stashpvs("UNIVERSAL", 0);
}
if (pkg) {
XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */
XS(XS_UNIVERSAL_DOES)
{
- dVAR;
dXSARGS;
PERL_UNUSED_ARG(cv);
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");
XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_valid)
{
- dVAR;
dXSARGS;
if (items != 1)
croak_xs_usage(cv, "sv");
XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_encode)
{
- dVAR;
dXSARGS;
if (items != 1)
croak_xs_usage(cv, "sv");
XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_decode)
{
- dVAR;
dXSARGS;
if (items != 1)
croak_xs_usage(cv, "sv");
XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */
XS(XS_utf8_upgrade)
{
- dVAR;
dXSARGS;
if (items != 1)
croak_xs_usage(cv, "sv");
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");
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));
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));
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;
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;
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;
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)))
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]");
XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_is_regexp)
{
- dVAR;
dXSARGS;
PERL_UNUSED_VAR(cv);
{
REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
SV * ret;
- dVAR;
dXSARGS;
if (items != 0)
XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regname)
{
- dVAR;
dXSARGS;
REGEXP * rx;
U32 flags;
XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regnames)
{
- dVAR;
dXSARGS;
REGEXP * rx;
U32 flags;
XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */
XS(XS_re_regexp_pattern)
{
- dVAR;
dXSARGS;
REGEXP *re;
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);
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;
STRLEN
Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
{
- dVAR;
STRLEN len = 0;
PERL_ARGS_ASSERT_UTF8_LENGTH;
*/
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. */
const U8 *const uend = u + ulen;
PERL_ARGS_ASSERT_BYTES_CMP_UTF8;
- PERL_UNUSED_CONTEXT;
while (b < bend && u < uend) {
U8 c = *u++;
bool
Perl__is_utf8_idstart(pTHX_ const U8 *p)
{
- dVAR;
PERL_ARGS_ASSERT__IS_UTF8_IDSTART;
if (*p == '_')
UV
Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
{
- dVAR;
-
/* Convert the Unicode character whose ordinal is <c> to its uppercase
* version and store that in UTF-8 in <p> and its length in bytes in <lenp>.
* Note that the <p> needs to be at least UTF8_MAXBYTES_CASE+1 bytes since
UV
Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp)
{
- dVAR;
-
PERL_ARGS_ASSERT_TO_UNI_TITLE;
if (c < 256) {
UV
Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp)
{
- dVAR;
-
PERL_ARGS_ASSERT_TO_UNI_LOWER;
if (c < 256) {
* 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 <p>,
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);
bool
Perl__is_utf8_perl_idstart(pTHX_ const U8 *p)
{
- dVAR;
SV* invlist = NULL;
PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART;
bool
Perl__is_utf8_xidstart(pTHX_ const U8 *p)
{
- dVAR;
-
PERL_ARGS_ASSERT__IS_UTF8_XIDSTART;
if (*p == '_')
bool
Perl__is_utf8_perl_idcont(pTHX_ const U8 *p)
{
- dVAR;
SV* invlist = NULL;
PERL_ARGS_ASSERT__IS_UTF8_PERL_IDCONT;
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);
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);
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);
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);
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;
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;
{
UV result;
- dVAR;
-
PERL_ARGS_ASSERT__TO_UTF8_LOWER_FLAGS;
if (flags && IN_UTF8_CTYPE_LOCALE) {
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;
*
* <invlist> is only valid for binary properties */
- dVAR;
SV* retval = &PL_sv_undef;
HV* swash_hv = NULL;
const int invlist_swash_boundary =
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;
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 */
* 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 \
{
#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) {
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);
}
void
Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
{
- dVAR;
const U8 *s;
STRLEN i;
STRLEN len;
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);
STATIC SV *
S_mess_alloc(pTHX)
{
- dVAR;
SV *sv;
XPVMG *any;
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. */
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
SV *
Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
{
- dVAR;
SV *sv;
#if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
*/
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;
SV *
Perl_vmess(pTHX_ const char *pat, va_list *args)
{
- dVAR;
SV * const sv = mess_alloc();
PERL_ARGS_ASSERT_VMESS;
void
Perl_write_to_stderr(pTHX_ SV* msv)
{
- dVAR;
IO *io;
MAGIC *mg;
STATIC bool
S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
{
- dVAR;
HV *stash;
GV *gv;
CV *cv;
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;
bool
Perl_ckwarn_d(pTHX_ U32 w)
{
- dVAR;
/* If lexical warnings have not been set then default classes warn. */
if (isLEXWARN_off)
return TRUE;
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;
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
- dVAR;
int p[2];
I32 This, that;
Pid_t pid;
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);
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);
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;
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;
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)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
- dVAR;
int status;
SV **svp;
Pid_t pid;
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
- dVAR;
I32 result = 0;
PERL_ARGS_ASSERT_WAIT4PID;
#ifdef PERL_USES_PL_PIDSTATUS
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];
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)
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
struct perl_vars *
Perl_GetVars(pTHX)
{
- return &PL_Vars;
+ PERL_UNUSED_CONTEXT;
+ return &PL_Vars;
}
#endif
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
* 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;
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;
Perl_getcwd_sv(pTHX_ SV *sv)
{
#ifndef PERL_MICRO
- dVAR;
SvTAINTED_on(sv);
PERL_ARGS_ASSERT_GETCWD_SV;
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
void
Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
{
- dVAR;
const char *env_pv;
unsigned long i;
# 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));
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);
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);
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);
void
Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
{
- dVAR;
SV * const dbsv = GvSVn(PL_DBsub);
const bool save_taint = TAINT_get;
}
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
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)
/* 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"
# 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
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 ..
-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 \
# 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
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 ..
-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 \
perl5200delta.pod \
perl5210delta.pod \
perl5211delta.pod \
+ perl5212delta.pod \
perl561delta.pod \
perl56delta.pod \
perl581delta.pod \
perl5200delta.man \
perl5210delta.man \
perl5211delta.man \
+ perl5212delta.man \
perl561delta.man \
perl56delta.man \
perl581delta.man \
perl5200delta.html \
perl5210delta.html \
perl5211delta.html \
+ perl5212delta.html \
perl561delta.html \
perl56delta.html \
perl581delta.html \
perl5200delta.tex \
perl5210delta.tex \
perl5211delta.tex \
+ perl5212delta.tex \
perl561delta.tex \
perl56delta.tex \
perl581delta.tex \
projects / platform / upstream / perl.git / commitdiff