# generated by the top level install.html target. XXX Why does it need this?
/vms/README_vms.pod
+
+# ctags
+tags
+TAGS
+# gtags
+GPATH
+GRPATH
+GRTAGS
+GTAGS
Albert Dvornik <bert@alum.mit.edu>
Alberto Simões <ambs@cpan.org>
Alessandro Forghieri <alf@orion.it>
+Alexandre (Midnite) Jousset <mid@gtmp.org>
Alexander Alekseev <alex@alemate.ru>
Alexander Hartmaier <abraxxa@cpan.org>
Alexander Voronov <alexander-voronov@yandex.ru>
Andy Lester <andy@petdance.com>
Anno Siegel <anno4000@lublin.zrz.tu-berlin.de>
Anthony David <adavid@netinfo.com.au>
+Anthony Heading <anthony@ajrh.net>
Anton Berezin <tobez@tobez.org>
Anton Nikishaev <me@lelf.lu>
Anton Tagunov <tagunov@motor.ru>
Charles Lane <lane@DUPHY4.Physics.Drexel.Edu>
Charles Randall <cfriv@yahoo.com>
Charles Wilson <cwilson@ece.gatech.edu>
-Charlie Gonzalez <itcharlie@gmail.com>
+Charlie Gonzalez <itcharlie@gmail.com>
Chas. Owens <chas.owens@gmail.com>
Chaskiel M Grundman
Chia-liang Kao <clkao@clkao.org>
Sven Verdoolaege <skimo@breughel.ufsia.ac.be>
syber <syber@crazypanda.ru>
SynaptiCAD, Inc. <sales@syncad.com>
+Tadeusz Sośnierz <tadeusz.sosnierz@onet.pl>
Takis Psarogiannakopoulos <takis@xfree86.org>
Taro KAWAGISHI
Tassilo von Parseval <tassilo.parseval@post.rwth-aachen.de>
d__fwalk=''
d_access=''
d_accessx=''
+d_acosh=''
d_aintl=''
d_alarm=''
asctime_r_proto=''
d_fd_macros=''
d_fd_set=''
d_fds_bits=''
+d_fegetround=''
d_fgetpos=''
d_finite=''
d_finitel=''
d_flockproto=''
d_fork=''
d_fp_class=''
+d_fp_classl=''
d_fpclass=''
+d_fp_classify=''
d_fpclassify=''
d_fpclassl=''
+d_fpgetround=''
d_fpos64_t=''
d_frexpl=''
d_fs_data_s=''
d_isascii=''
d_isblank=''
d_isfinite=''
+d_isfinitel=''
d_isinf=''
+d_isinfl=''
d_isnan=''
d_isnanl=''
+d_j0=''
+d_j0l=''
d_killpg=''
d_lchown=''
d_ldbl_dig=''
-d_ldexpl=''
d_libm_lib_version=''
d_link=''
d_localtime_r=''
localtime_r_proto=''
d_locconv=''
d_lockf=''
+d_ldexpl=''
d_longdbl=''
longdblkind=''
longdblsize=''
d_tmpnam_r=''
tmpnam_r_proto=''
d_truncate=''
+d_truncl=''
d_ttyname_r=''
ttyname_r_proto=''
d_tzname=''
i_dlfcn=''
i_execinfo=''
i_fcntl=''
+i_fenv=''
i_float=''
i_fp=''
i_fp_class=''
d_pwpasswd=''
d_pwquota=''
i_pwd=''
+i_quadmath=''
i_shadow=''
i_socks=''
i_stdbool=''
i_stddef=''
+i_stdint=''
i_stdlib=''
i_string=''
strings=''
uselargefiles=''
uselongdouble=''
usemorebits=''
+usequadmath=''
usemultiplicity=''
nm_opt=''
nm_so_opt=''
# The most common problem is -D_REENTRANT for threads.
# This heuristic catches that case, but gets false positives
# if -Dusethreads was not actually specified. Better to
- # bail out here with a useful message than fail
+ # bail out here with a useful message than fail
# mysteriously later. Should we perhaps just try to
# re-invoke Configure -Dcc=gcc config_args ?
if $test -f usethreads.cbu; then
- $cat >&4 <<EOM
+ $cat >&4 <<EOM
*** However, any setting of the C compiler flags (e.g. for thread support)
*** will be lost. It may be necessary for you to restart Configure and
echo "Cannot find myread, sorry. Aborting." >&2
exit 1
fi
- fi
+ fi
case "$ans" in
[yY]*) cc=gcc; ccname=gcc; ccflags=''; despair=no;
esac
$startsh
EOS
cat <<'EOSC' >>checkcc
-case "$cc" in
+case "$cc" in
'') ;;
-*) $rm -f try try.*
+*) $rm -f try try.*
$cat >try.c <<EOM
int main(int argc, char *argv[]) {
return 0;
if $test X"$despair" = Xyes; then
echo "Uh-oh, the C compiler '$cc' doesn't seem to be working." >&4
fi
- $cat >&4 <<EOM
+ $cat >&4 <<EOM
You need to find a working C compiler.
Either (purchase and) install the C compiler supplied by your OS vendor,
or for a free C compiler try http://gcc.gnu.org/
set usemultiplicity
eval $setvar
+: Check if usequadmath is requested
+case "$usequadmath" in
+"$define"|true|[yY]*)
+ usequadmath="$define"
+ # if usequadmath enabled also enable uselongdouble
+ uselongdouble="$define"
+ ;;
+*) usequadmath="$undef" ;;
+esac
+
: Check if morebits is requested
case "$usemorebits" in
"$define"|true|[yY]*)
case "$usecbacktrace" in
"$define") libswanted="$libswanted bfd" ;;
esac
+case "$usequadmath" in
+"$define") libswanted="$libswanted quadmath" ;;
+esac
libsfound=''
libsfiles=''
libsdirs=''
xxx=`ls $thisdir/lib$thislib.$so.[0-9] 2>/dev/null|sed -n '$p'`
$test -f "$xxx" && eval $libscheck
$test -f "$xxx" && libstyle=shared
+ xxx=`ls $thisdir/lib$thislib.[0-9].$so 2>/dev/null|sed -n '$p'`
+ $test -f "$xxx" && eval $libscheck
+ $test -f "$xxx" && libstyle=shared
fi
if test ! -f "$xxx"; then
xxx=$thisdir/lib$thislib.$so
# as that way the compiler can do the right implementation dependant
# thing. (NWC)
case "$gccversion" in
- ?*) set stack-protector -fstack-protector
+ ?*) set stack-protector-strong -fstack-protector-strong
eval $checkccflag
+ case "$dflt" in
+ *-fstack-protector-strong*) ;; # It got added.
+ *) # Try the plain/older -fstack-protector.
+ set stack-protector -fstack-protector
+ eval $checkccflag
+ ;;
+ esac
;;
esac
;;
esac
# See note above about -fstack-protector
case "$ccflags" in
+*-fstack-protector-strong*)
+ case "$dflt" in
+ *-fstack-protector-strong*) ;; # Don't add it again
+ *) dflt="$dflt -fstack-protector-strong" ;;
+ esac
+ ;;
*-fstack-protector*)
case "$dflt" in
*-fstack-protector*) ;; # Don't add it again
;;
esac
-: check for length of double
+: Check if we are using the GNU C library
echo " "
-case "$doublesize" in
-'')
- echo "Checking to see how big your double precision numbers are..." >&4
- $cat >try.c <<EOCP
+echo "Checking for GNU C Library..." >&4
+cat >try.c <<'EOCP'
+/* Find out version of GNU C library. __GLIBC__ and __GLIBC_MINOR__
+ alone are insufficient to distinguish different versions, such as
+ 2.0.6 and 2.0.7. The function gnu_get_libc_version() appeared in
+ libc version 2.1.0. A. Dougherty, June 3, 2002.
+*/
#include <stdio.h>
-#$i_stdlib I_STDLIB
-#ifdef I_STDLIB
-#include <stdlib.h>
-#endif
-int main()
+int main(void)
{
- printf("%d\n", (int)sizeof(double));
- exit(0);
+#ifdef __GLIBC__
+# ifdef __GLIBC_MINOR__
+# if __GLIBC__ >= 2 && __GLIBC_MINOR__ >= 1 && !defined(__cplusplus)
+# include <gnu/libc-version.h>
+ printf("%s\n", gnu_get_libc_version());
+# else
+ printf("%d.%d\n", __GLIBC__, __GLIBC_MINOR__);
+# endif
+# else
+ printf("%d\n", __GLIBC__);
+# endif
+ return 0;
+#else
+ return 1;
+#endif
}
EOCP
- set try
- if eval $compile_ok; then
- doublesize=`$run ./try`
- echo "Your double is $doublesize bytes long."
- else
- dflt='8'
- echo "(I can't seem to compile the test program. Guessing...)"
- rp="What is the size of a double precision number (in bytes)?"
- . ./myread
- doublesize="$ans"
- fi
- ;;
-esac
-$rm_try
-
-: check for long doubles
-echo " "
-echo "Checking to see if you have long double..." >&4
-echo 'int main() { long double x = 7.0; }' > try.c
set try
-if eval $compile; then
+if eval $compile_ok && $run ./try > glibc.ver; then
val="$define"
- echo "You have long double."
+ gnulibc_version=`$cat glibc.ver`
+ echo "You are using the GNU C Library version $gnulibc_version"
else
val="$undef"
- echo "You do not have long double."
+ gnulibc_version=''
+ echo "You are not using the GNU C Library"
fi
-$rm_try
-set d_longdbl
+$rm_try glibc.ver
+set d_gnulibc
eval $setvar
-: check for length of long double
-case "${d_longdbl}${longdblsize}" in
-$define)
- echo " "
- echo "Checking to see how big your long doubles are..." >&4
- $cat >try.c <<'EOCP'
-#include <stdio.h>
-int main()
-{
- printf("%d\n", sizeof(long double));
-}
-EOCP
- set try
- set try
- if eval $compile; then
- longdblsize=`$run ./try`
- echo "Your long doubles are $longdblsize bytes long."
- else
- dflt='8'
+: see if nm is to be used to determine whether a symbol is defined or not
+case "$usenm" in
+'')
+ dflt=''
+ case "$d_gnulibc" in
+ "$define")
echo " "
- echo "(I can't seem to compile the test program. Guessing...)" >&4
- rp="What is the size of a long double (in bytes)?"
- . ./myread
- longdblsize="$ans"
- fi
- if $test "X$doublesize" = "X$longdblsize"; then
- echo "That isn't any different from an ordinary double."
- echo "I'll keep your setting anyway, but you may see some"
- echo "harmless compilation warnings."
- fi
+ echo "nm probably won't work on the GNU C Library." >&4
+ dflt=n
+ ;;
+ esac
+ case "$dflt" in
+ '')
+ if $test "$osname" = aix -a "X$PASE" != "Xdefine" -a ! -f /lib/syscalls.exp; then
+ echo " "
+ echo "Whoops! This is an AIX system without /lib/syscalls.exp!" >&4
+ echo "'nm' won't be sufficient on this system." >&4
+ dflt=n
+ fi
+ ;;
+ esac
+ case "$dflt" in
+ '') dflt=`$egrep 'inlibc|csym' $rsrc/Configure | wc -l 2>/dev/null`
+ if $test $dflt -gt 20; then
+ dflt=y
+ else
+ dflt=n
+ fi
+ ;;
+ esac
;;
-esac
-$rm_try
-
-: determine the architecture name
-echo " "
-if xxx=`./loc arch blurfl $pth`; $test -f "$xxx"; then
- tarch=`arch`"-$osname"
-elif xxx=`./loc uname blurfl $pth`; $test -f "$xxx" ; then
- if uname -m > tmparch 2>&1 ; then
- tarch=`$sed -e 's/ *$//' -e 's/ /_/g' \
- -e 's/$/'"-$osname/" tmparch`
- else
- tarch="$osname"
- fi
- $rm -f tmparch
-else
- tarch="$osname"
-fi
-case "$myarchname" in
-''|"$tarch") ;;
*)
- echo "(Your architecture name used to be $myarchname.)"
- archname=''
+ case "$usenm" in
+ true|$define) dflt=y;;
+ *) dflt=n;;
+ esac
;;
esac
-case "$targetarch" in
-'') ;;
-*) archname=`echo $targetarch|sed 's,^[^-]*-,,'` ;;
-esac
-myarchname="$tarch"
-case "$archname" in
-'') dflt="$tarch";;
-*) dflt="$archname";;
-esac
-rp='What is your architecture name'
-. ./myread
-archname="$ans"
+$cat <<EOM
-: optionally add API version to the architecture for versioned archlibs
-case "$useversionedarchname" in
-$define|true|[yY]*) dflt='y';;
-*) dflt='n';;
-esac
-rp='Add the Perl API version to your archname?'
+I can use $nm to extract the symbols from your C libraries. This
+is a time consuming task which may generate huge output on the disk (up
+to 3 megabytes) but that should make the symbols extraction faster. The
+alternative is to skip the 'nm' extraction part and to compile a small
+test program instead to determine whether each symbol is present. If
+you have a fast C compiler and/or if your 'nm' output cannot be parsed,
+this may be the best solution.
+
+You probably shouldn't let me use 'nm' if you are using the GNU C Library.
+
+EOM
+rp="Shall I use $nm to extract C symbols from the libraries?"
. ./myread
case "$ans" in
-y|Y) useversionedarchname="$define" ;;
-*) useversionedarchname="$undef" ;;
+[Nn]*) usenm=false;;
+*) usenm=true;;
esac
-case "$useversionedarchname" in
-$define)
- case "$archname" in
- *-$api_versionstring)
- echo "...and architecture name already has -$api_versionstring" >&4
- ;;
- *)
- archname="$archname-$api_versionstring"
- echo "...setting architecture name to $archname." >&4
- ;;
- esac
- ;;
+
+runnm=$usenm
+case "$reuseval" in
+true) runnm=false;;
esac
-case "$usethreads" in
-$define)
- echo "Threads selected." >&4
- case "$archname" in
- *-thread*) echo "...and architecture name already has -thread." >&4
- ;;
- *) archname="$archname-thread"
- echo "...setting architecture name to $archname." >&4
- ;;
- esac
+: nm options which may be necessary
+case "$nm_opt" in
+'') if $test -f /mach_boot; then
+ nm_opt='' # Mach
+ elif $test -d /usr/ccs/lib; then
+ nm_opt='-p' # Solaris (and SunOS?)
+ elif $test -f /dgux; then
+ nm_opt='-p' # DG-UX
+ elif $test -f /lib64/rld; then
+ nm_opt='-p' # 64-bit Irix
+ else
+ nm_opt=''
+ fi;;
+esac
+
+: nm options which may be necessary for shared libraries but illegal
+: for archive libraries. Thank you, Linux.
+case "$nm_so_opt" in
+'') case "$myuname" in
+ *linux*|gnu*)
+ if $nm --help | $grep 'dynamic' > /dev/null 2>&1; then
+ nm_so_opt='--dynamic'
+ fi
+ ;;
+ esac
;;
esac
-case "$usemultiplicity" in
-$define)
- echo "Multiplicity selected." >&4
- case "$archname" in
- *-multi*) echo "...and architecture name already has -multi." >&4
- ;;
- *) archname="$archname-multi"
- echo "...setting architecture name to $archname." >&4
- ;;
- esac
- ;;
-esac
-case "$use64bitint$use64bitall" in
-*"$define"*)
- case "$archname64" in
- '')
- echo "This architecture is naturally 64-bit, not changing architecture name." >&4
- ;;
- *)
- case "$use64bitint" in
- "$define") echo "64 bit integers selected." >&4 ;;
- esac
- case "$use64bitall" in
- "$define") echo "Maximal 64 bitness selected." >&4 ;;
- esac
- case "$archname" in
- *-$archname64*) echo "...and architecture name already has $archname64." >&4
- ;;
- *) archname="$archname-$archname64"
- echo "...setting architecture name to $archname." >&4
- ;;
- esac
- ;;
+
+: Figure out where the libc is located
+case "$runnm" in
+true)
+: get list of predefined functions in a handy place
+echo " "
+case "$libc" in
+'') libc=unknown
+ case "$libs" in
+ *-lc_s*) libc=`./loc libc_s$_a $libc $libpth`
esac
+ ;;
esac
-case "$uselongdouble" in
-$define)
- echo "Long doubles selected." >&4
- case "$longdblsize" in
- $doublesize)
- echo "...but long doubles are equal to doubles, not changing architecture name." >&4
+case "$libs" in
+'') ;;
+*) for thislib in $libs; do
+ case "$thislib" in
+ -lc|-lc_s)
+ : Handle C library specially below.
;;
- *)
- case "$archname" in
- *-ld*) echo "...and architecture name already has -ld." >&4
- ;;
- *) archname="$archname-ld"
- echo "...setting architecture name to $archname." >&4
- ;;
- esac
+ -l*)
+ thislib=`echo $thislib | $sed -e 's/^-l//'`
+ if try=`./loc lib$thislib.$so.'*' X $libpth`; $test -f "$try"; then
+ :
+ elif try=`./loc lib$thislib.$so X $libpth`; $test -f "$try"; then
+ :
+ elif try=`./loc lib$thislib$_a X $libpth`; $test -f "$try"; then
+ :
+ elif try=`./loc $thislib$_a X $libpth`; $test -f "$try"; then
+ :
+ elif try=`./loc lib$thislib X $libpth`; $test -f "$try"; then
+ :
+ elif try=`./loc $thislib X $libpth`; $test -f "$try"; then
+ :
+ elif try=`./loc Slib$thislib$_a X $xlibpth`; $test -f "$try"; then
+ :
+ else
+ try=''
+ fi
+ libnames="$libnames $try"
;;
+ *) libnames="$libnames $thislib" ;;
esac
+ done
;;
esac
-if $test -f archname.cbu; then
- echo "Your platform has some specific hints for architecture name, using them..."
- . ./archname.cbu
-fi
-
-: set the prefixit variable, to compute a suitable default value
-prefixit='case "$3" in
-""|none)
- case "$oldprefix" in
- "") eval "$1=\"\$$2\"";;
- *)
- case "$3" in
- "") eval "$1=";;
- none)
- eval "tp=\"\$$2\"";
- case "$tp" in
- ""|" ") eval "$1=\"\$$2\"";;
- *) eval "$1=";;
- esac;;
- esac;;
- esac;;
+xxx=normal
+case "$libc" in
+unknown)
+ set /lib/libc.$so
+ for xxx in $libpth; do
+ $test -r $1 || set $xxx/libc.$so
+ : The messy sed command sorts on library version numbers.
+ $test -r $1 || \
+ set `echo blurfl; echo $xxx/libc.$so.[0-9]* | \
+ tr ' ' $trnl | egrep -v '\.[A-Za-z]*$' | $sed -e '
+ h
+ s/[0-9][0-9]*/0000&/g
+ s/0*\([0-9][0-9][0-9][0-9][0-9]\)/\1/g
+ G
+ s/\n/ /' | \
+ $sort | $sed -e 's/^.* //'`
+ eval set \$$#
+ done
+ $test -r $1 || set $sysroot/usr/ccs/lib/libc.$so
+ $test -r $1 || set $sysroot/lib/libsys_s$_a
+ ;;
*)
- eval "tp=\"$oldprefix-\$$2-\""; eval "tp=\"$tp\"";
- case "$tp" in
- --|/*--|\~*--) eval "$1=\"$prefix/$3\"";;
- /*-$oldprefix/*|\~*-$oldprefix/*)
- eval "$1=\`echo \$$2 | sed \"s,^$oldprefix,$prefix,\"\`";;
- *) eval "$1=\"\$$2\"";;
- esac;;
-esac'
-
-: determine installation style
-: For now, try to deduce it from prefix unless it is already set.
-: Reproduce behavior of 5.005 and earlier, maybe drop that in 5.7.
-case "$installstyle" in
-'') case "$prefix" in
- *perl*) dflt='lib';;
- *) dflt='lib/perl5' ;;
- esac
+ set blurfl
;;
-*) dflt="$installstyle" ;;
esac
-: Probably not worth prompting for this since we prompt for all
-: the directories individually, and the prompt would be too long and
-: confusing anyway.
-installstyle=$dflt
-
-: determine where public executables go
-echo " "
-set dflt bin bin
-eval $prefixit
-fn=d~
-rp='Pathname where the public executables will reside?'
-. ./getfile
-if $test "X$ansexp" != "X$binexp"; then
- installbin=''
+if $test -r "$1"; then
+ echo "Your (shared) C library seems to be in $1."
+ libc="$1"
+elif $test -r /lib/libc && $test -r /lib/clib; then
+ echo "Your C library seems to be in both /lib/clib and /lib/libc."
+ xxx=apollo
+ libc='/lib/clib /lib/libc'
+ if $test -r /lib/syslib; then
+ echo "(Your math library is in /lib/syslib.)"
+ libc="$libc /lib/syslib"
+ fi
+elif $test -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then
+ echo "Your C library seems to be in $libc, as you said before."
+elif $test -r $incpath/usr/lib/libc$_a; then
+ libc=$incpath/usr/lib/libc$_a;
+ echo "Your C library seems to be in $libc. That's fine."
+elif $test -r /lib/libc$_a; then
+ libc=/lib/libc$_a;
+ echo "Your C library seems to be in $libc. You're normal."
+else
+ if tans=`./loc libc$_a blurfl/dyick $libpth`; $test -r "$tans"; then
+ :
+ elif tans=`./loc libc blurfl/dyick $libpth`; $test -r "$tans"; then
+ libnames="$libnames "`./loc clib blurfl/dyick $libpth`
+ elif tans=`./loc clib blurfl/dyick $libpth`; $test -r "$tans"; then
+ :
+ elif tans=`./loc Slibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then
+ :
+ elif tans=`./loc Mlibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then
+ :
+ else
+ tans=`./loc Llibc$_a blurfl/dyick $xlibpth`
+ fi
+ if $test -r "$tans"; then
+ echo "Your C library seems to be in $tans, of all places."
+ libc=$tans
+ else
+ libc='blurfl'
+ fi
fi
-prefixvar=bin
-: XXX Bug? -- ignores Configure -Dinstallprefix setting.
-: XXX If this is fixed, also fix the "start perl" hunk below, which relies on
-: this via initialinstalllocation
-. ./setprefixvar
+if $test $xxx = apollo -o -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then
+ dflt="$libc"
+ cat <<EOM
-case "$userelocatableinc" in
-$define|true|[yY]*) dflt='y' ;;
-*) dflt='n' ;;
-esac
-cat <<EOM
+If the guess above is wrong (which it might be if you're using a strange
+compiler, or your machine supports multiple models), you can override it here.
-Would you like to build Perl so that the installation is relocatable, so that
-library paths in @INC are determined relative to the path of the perl binary?
-This is not advised for system Perl installs, or if you need to run setid
-scripts or scripts under taint mode.
+EOM
+else
+ dflt=''
+ echo $libpth | $tr ' ' $trnl | $sort | $uniq > libpath
+ cat >&4 <<EOM
+I can't seem to find your C library. I've looked in the following places:
-If this doesn't make any sense to you, just accept the default '$dflt'.
EOM
-rp='Use relocatable @INC?'
-. ./myread
-case "$ans" in
-y|Y) val="$define" ;;
-*) val="$undef" ;;
-esac
-set userelocatableinc
-eval $setvar
+ $sed 's/^/ /' libpath
+ cat <<EOM
-initialinstalllocation="$binexp"
-: Default prefix is now "up one level from where the binaries are"
-case "$userelocatableinc" in
-$define|true|[yY]*)
- bin=".../"
- binexp=".../"
- prefix=".../.."
- prefixexp=".../.."
- installprefixexp=".../.."
- ;;
-esac
-
-: determine where private library files go
-: Usual default is /usr/local/lib/perl5/$version.
-: Also allow things like /opt/perl/lib/$version, since
-: /opt/perl/lib/perl5... would be redundant.
-: The default "style" setting is made in installstyle.U
-case "$installstyle" in
-*lib/perl5*) set dflt privlib lib/$package/$version ;;
-*) set dflt privlib lib/$version ;;
-esac
-eval $prefixit
-$cat <<EOM
-
-There are some auxiliary files for $package that need to be put into a
-private library directory that is accessible by everyone.
+None of these seems to contain your C library. I need to get its name...
EOM
-fn=$binexp
-fn=d~+
-rp='Pathname where the private library files will reside?'
+fi
+fn=f
+rp='Where is your C library?'
. ./getfile
-prefixvar=privlib
-. ./setprefixvar
-
-: set the prefixup variable, to restore leading tilda escape
-prefixup='case "$prefixexp" in
-"$prefix") ;;
-*) eval "$1=\`echo \$$1 | sed \"s,^$prefixexp,$prefix,\"\`";;
-esac'
+libc="$ans"
-: determine where public architecture dependent libraries go
-set archlib archlib
-eval $prefixit
-: privlib default is /usr/local/lib/$package/$version
-: archlib default is /usr/local/lib/$package/$version/$archname
-: privlib may have an optional trailing /share.
-tdflt=`echo $privlib | $sed 's,/share$,,'`
-tdflt=$tdflt/$archname
-case "$archlib" in
-'') dflt=$tdflt
- ;;
-*) dflt="$archlib"
- ;;
-esac
-$cat <<EOM
+echo " "
+echo $libc $libnames | $tr ' ' $trnl | $sort | $uniq > libnames
+set X `cat libnames`
+shift
+xxx=files
+case $# in 1) xxx=file; esac
+echo "Extracting names from the following $xxx for later perusal:" >&4
+echo " "
+$sed 's/^/ /' libnames >&4
+echo " "
+$echo $n "This may take a while...$c" >&4
-$spackage contains architecture-dependent library files. If you are
-sharing libraries in a heterogeneous environment, you might store
-these files in a separate location. Otherwise, you can just include
-them with the rest of the public library files.
+for file in $*; do
+ case $file in
+ *$so*) $nm $nm_so_opt $nm_opt $file 2>/dev/null;;
+ *) $nm $nm_opt $file 2>/dev/null;;
+ esac
+done >libc.tmp
-EOM
-fn=$binexp
-fn=d+~
-rp='Where do you want to put the public architecture-dependent libraries?'
-. ./getfile
-prefixvar=archlib
-. ./setprefixvar
-if $test X"$archlib" = X"$privlib"; then
- d_archlib="$undef"
+$echo $n ".$c"
+$grep fprintf libc.tmp > libc.ptf
+xscan='eval "<libc.ptf $com >libc.list"; $echo $n ".$c" >&4'
+xrun='eval "<libc.tmp $com >libc.list"; echo "done." >&4'
+xxx='[ADTSIWi]'
+if com="$sed -n -e 's/__IO//' -e 's/^.* $xxx *//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^__*//' -e 's/^\([a-zA-Z_0-9$]*\).*xtern.*/\1/p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e '/|UNDEF/d' -e '/FUNC..GL/s/^.*|__*//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^.* D __*//p' -e 's/^.* D //p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^_//' -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$grep '|' | $sed -n -e '/|COMMON/d' -e '/|DATA/d' \
+ -e '/ file/d' -e 's/^\([^ ]*\).*/\1/p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p' -e 's/^.*|FUNC |WEAK .*|//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^__//' -e '/|Undef/d' -e '/|Proc/s/ .*//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^.*|Proc .*|Text *| *//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e '/Def. Text/s/.* \([^ ]*\)\$/\1/p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^[-0-9a-f ]*_\(.*\)=.*/\1/p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/.*\.text n\ \ \ \.//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="sed -n -e 's/^__.*//' -e 's/[ ]*D[ ]*[0-9]*.*//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
else
- d_archlib="$define"
-fi
-
-: see if setuid scripts can be secure
-$cat <<EOM
-
-Some kernels have a bug that prevents setuid #! scripts from being
-secure. Some sites have disabled setuid #! scripts because of this.
-
-First let's decide if your kernel supports secure setuid #! scripts.
-(If setuid #! scripts would be secure but have been disabled anyway,
-don't say that they are secure if asked.)
-
-EOM
-
-val="$undef"
-if $test -d /dev/fd; then
- echo "#!$ls" >reflect
- chmod +x,u+s reflect
- ./reflect >flect 2>&1
- if $contains "/dev/fd" flect >/dev/null; then
- echo "Congratulations, your kernel has secure setuid scripts!" >&4
- val="$define"
+ $nm -p $* 2>/dev/null >libc.tmp
+ $grep fprintf libc.tmp > libc.ptf
+ if com="$sed -n -e 's/^.* [ADTSIW] *_[_.]*//p' -e 's/^.* [ADTSIW] //p'";\
+ eval $xscan; $contains '^fprintf$' libc.list >/dev/null 2>&1
+ then
+ nm_opt='-p'
+ eval $xrun
else
- $cat <<EOM
-If you are not sure if they are secure, I can check but I'll need a
-username and password different from the one you are using right now.
-If you don't have such a username or don't want me to test, simply
-enter 'none'.
-
-EOM
- rp='Other username to test security of setuid scripts with?'
- dflt='none'
- . ./myread
- case "$ans" in
- n|none)
- case "$d_suidsafe" in
- '') echo "I'll assume setuid scripts are *not* secure." >&4
- dflt=n;;
- "$undef")
- echo "Well, the $hint value is *not* secure." >&4
- dflt=n;;
- *) echo "Well, the $hint value *is* secure." >&4
- dflt=y;;
- esac
- ;;
- *)
- $rm -f reflect flect
- echo "#!$ls" >reflect
- chmod +x,u+s reflect
- echo >flect
- chmod a+w flect
- echo '"su" will (probably) prompt you for '"$ans's password."
- su $ans -c './reflect >flect'
- if $contains "/dev/fd" flect >/dev/null; then
- echo "Okay, it looks like setuid scripts are secure." >&4
- dflt=y
+ echo " "
+ echo "$nm didn't seem to work right. Trying $ar instead..." >&4
+ com=''
+ if $ar t $libc > libc.tmp && \
+ $contains '^fprintf$' libc.tmp >/dev/null 2>&1
+ then
+ for thisname in $libnames $libc; do
+ $ar t $thisname >>libc.tmp
+ done
+ $sed -e "s/\\$_o\$//" < libc.tmp > libc.list
+ echo "Ok." >&4
+ elif test "X$osname" = "Xos2" && $ar tv $libc > libc.tmp; then
+ for thisname in $libnames $libc; do
+ $ar tv $thisname >>libc.tmp
+ emximp -o tmp.imp $thisname \
+ 2>/dev/null && \
+ $sed -e 's/^\([_a-zA-Z0-9]*\) .*$/\1/p' \
+ < tmp.imp >>libc.tmp
+ $rm -f tmp.imp
+ done
+ $sed -e "s/\\$_o\$//" -e 's/^ \+//' < libc.tmp > libc.list
+ echo "Ok." >&4
+ else
+ echo "$ar didn't seem to work right." >&4
+ echo "Maybe this is a Cray...trying bld instead..." >&4
+ if bld t $libc | \
+ $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" > libc.list &&
+ $test -s libc.list
+ then
+ for thisname in $libnames; do
+ bld t $libnames | \
+ $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" >>libc.list
+ $ar t $thisname >>libc.tmp
+ done
+ echo "Ok." >&4
else
- echo "I don't think setuid scripts are secure." >&4
- dflt=n
+ echo "That didn't work either. Giving up." >&4
+ exit 1
fi
- ;;
- esac
- rp='Does your kernel have *secure* setuid scripts?'
- . ./myread
- case "$ans" in
- [yY]*) val="$define";;
- *) val="$undef";;
- esac
+ fi
fi
-else
- echo "I don't think setuid scripts are secure (no /dev/fd directory)." >&4
- echo "(That's for file descriptors, not floppy disks.)"
- val="$undef"
fi
-set d_suidsafe
-eval $setvar
-
-$rm -f reflect flect
-
-: now see if they want to do setuid emulation
-if $test $patchlevel -lt 11; then
-echo " "
-val="$undef"
-case "$d_suidsafe" in
-"$define")
- val="$undef"
- echo "No need to emulate SUID scripts since they are secure here." >&4
- ;;
-*)
- $cat <<EOM
-Some systems have disabled setuid scripts, especially systems where
-setuid scripts cannot be secure. On systems where setuid scripts have
-been disabled, the setuid/setgid bits on scripts are currently
-useless. It is possible for $package to detect those bits and emulate
-setuid/setgid in a secure fashion. This emulation will only work if
-setuid scripts have been disabled in your kernel.
-
-EOM
- case "$d_dosuid" in
- "$define") dflt=y ;;
- *) dflt=n ;;
- esac
- rp="Do you want to do setuid/setgid emulation?"
- . ./myread
- case "$ans" in
- [yY]*) val="$define";;
- *) val="$undef";;
- esac
- ;;
-esac
-set d_dosuid
-eval $setvar
-else
- case "$d_dosuid" in
- "$define")
- cat >&4 <<EOH
-
-SUID emulation has been removed for 5.12
-Please re-run Configure without -Dd_dosuid
-
-EOH
- exit 1;
- ;;
- esac
- d_dosuid=undef
-fi
-
-: Find perl5.005 or later.
-echo "Looking for a previously installed perl5.005 or later... "
-case "$perl5" in
-'') for tdir in `echo "$binexp$path_sep$PATH" | $sed "s/$path_sep/ /g"`; do
- : Check if this perl is recent and can load a simple module
- if $test -x $tdir/perl$exe_ext && $tdir/perl -Mless -e 'use 5.005;' >/dev/null 2>&1; then
- perl5=$tdir/perl
- break;
- elif $test -x $tdir/perl5$exe_ext && $tdir/perl5 -Mless -e 'use 5.005;' >/dev/null 2>&1; then
- perl5=$tdir/perl5
- break;
- fi
- done
- ;;
-*) perl5="$perl5"
- ;;
+nm_extract="$com"
+case "$PASE" in
+define)
+ echo " "
+ echo "Since you are compiling for PASE, extracting more symbols from libc.a ...">&4
+ dump -Tv /lib/libc.a | awk '$7 == "/unix" {print $5 " " $8}' | grep "^SV" | awk '{print $2}' >> libc.list
+ ;;
+*) if $test -f /lib/syscalls.exp; then
+ echo " "
+ echo "Also extracting names from /lib/syscalls.exp for good ole AIX..." >&4
+ $sed -n 's/^\([^ ]*\)[ ]*syscall[0-9]*[ ]*$/\1/p' \
+ /lib/syscalls.exp >>libc.list
+ fi
+ ;;
esac
-case "$perl5" in
-'') echo "None found. That's ok.";;
-*) echo "Using $perl5." ;;
+;;
esac
+$rm -f libnames libpath
-: Set the siteprefix variables
-$cat <<EOM
-
-After $package is installed, you may wish to install various
-add-on modules and utilities. Typically, these add-ons will
-be installed under $prefix with the rest
-of this package. However, you may wish to install such add-ons
-elsewhere under a different prefix.
-
-If you do not wish to put everything under a single prefix, that's
-ok. You will be prompted for the individual locations; this siteprefix
-is only used to suggest the defaults.
-
-The default should be fine for most people.
-
-EOM
-fn=d~+
-rp='Installation prefix to use for add-on modules and utilities?'
-: XXX Here might be another good place for an installstyle setting.
-case "$siteprefix" in
-'') dflt=$prefix ;;
-*) dflt=$siteprefix ;;
-esac
-. ./getfile
-: XXX Prefixit unit does not yet support siteprefix and vendorprefix
-oldsiteprefix=''
-case "$siteprefix" in
-'') ;;
-*) case "$ans" in
- "$prefix") ;;
- *) oldsiteprefix="$prefix";;
- esac
- ;;
-esac
-siteprefix="$ans"
-siteprefixexp="$ansexp"
+: Check if we are using C++
+echo " "
+echo "Checking for C++..." >&4
+$cat >try.c <<'EOCP'
+#include <stdio.h>
+int main(void)
+{
+#ifdef __cplusplus
+ return 0;
+#else
+ return 1;
+#endif
+}
+EOCP
+set try
+if eval $compile_ok && $run ./try; then
+ val="$define"
+ echo "You are using a C++ compiler."
+else
+ val="$undef"
+ echo "You are not using a C++ compiler."
+fi
+$rm_try cplusplus$$
+set d_cplusplus
+eval $setvar
-: determine where site specific libraries go.
-: Usual default is /usr/local/lib/perl5/site_perl/$version
-: The default "style" setting is made in installstyle.U
-: XXX No longer works with Prefixit stuff.
-prog=`echo $package | $sed 's/-*[0-9.]*$//'`
-case "$sitelib" in
-'') case "$installstyle" in
- *lib/perl5*) dflt=$siteprefix/lib/$package/site_$prog/$version ;;
- *) dflt=$siteprefix/lib/site_$prog/$version ;;
- esac
+: is a C symbol defined?
+csym='tlook=$1;
+case "$3" in
+-v) tf=libc.tmp; tdc="";;
+-a) tf=libc.tmp; tdc="[]";;
+*) tlook="^$1\$"; tf=libc.list; tdc="()";;
+esac;
+case "$d_cplusplus" in
+ $define) extern_C="extern \"C\"" ;;
+ *) extern_C="extern" ;;
+esac;
+tx=yes;
+case "$reuseval-$4" in
+true-) ;;
+true-*) tx=no; eval "tval=\$$4"; case "$tval" in "") tx=yes;; esac;;
+esac;
+case "$tx" in
+yes)
+ tval=false;
+ if $test "$runnm" = true; then
+ if $contains $tlook $tf >/dev/null 2>&1; then
+ tval=true;
+ elif $test "$mistrustnm" = compile -o "$mistrustnm" = run; then
+ echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { return &$1; } int main() { if(p() && p() != (void *)main) return(0); else return(1); }"> try.c;
+ $cc -o try $optimize $ccflags $ldflags try.c >/dev/null 2>&1 $libs && tval=true;
+ $test "$mistrustnm" = run -a -x try && { $run ./try$_exe >/dev/null 2>&1 || tval=false; };
+ $rm_try;
+ fi;
+ else
+ echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { return &$1; } int main() { if(p() && p() != (void *)main) return(0); else return(1); }"> try.c;
+ $cc -o try $optimize $ccflags $ldflags try.c $libs >/dev/null 2>&1 && tval=true;
+ $rm_try;
+ fi;
;;
-*) dflt="$sitelib"
+*)
+ case "$tval" in
+ $define) tval=true;;
+ *) tval=false;;
+ esac;
;;
-esac
-$cat <<EOM
-
-The installation process will create a directory for
-site-specific extensions and modules. Most users find it convenient
-to place all site-specific files in this directory rather than in the
-main distribution directory.
-
-EOM
-fn=d~+
-rp='Pathname for the site-specific library files?'
-. ./getfile
-prefixvar=sitelib
-. ./setprefixvar
-sitelib_stem=`echo "$sitelibexp" | sed "s,/$version$,,"`
-
-: Determine list of previous versions to include in @INC
-$cat > getverlist <<EOPL
-#!$perl5 -w
-use File::Basename;
-\$api_versionstring = "$api_versionstring";
-\$version = "$version";
-\$stem = "$sitelib_stem";
-\$archname = "$archname";
-EOPL
- $cat >> getverlist <<'EOPL'
-# The list found is store twice for each entry: the original name, and
-# the binary broken down version as pack "sss", so sorting is easy and
-# unambiguous. This will work for all versions that have a maximum of
-# three digit groups, separate by '.'s or '_'s. Names are extended with
-# ".0.0" to ensure at least three elements for the pack.
-# -- H.Merijn Brand (m)'06 23-10-2006
-
-# Can't have leading @ because metaconfig interprets it as a command!
-;@inc_version_list=();
-# XXX Redo to do opendir/readdir?
-if (-d $stem) {
- chdir($stem);
- ;@candidates = map {
- [ $_, pack "sss", split m/[._]/, "$_.0.0" ] } glob("5.*");
- ;@candidates = sort { $a->[1] cmp $b->[1]} @candidates;
-}
-else {
- ;@candidates = ();
-}
+esac;
+eval "$2=$tval"'
-($pversion, $aversion, $vsn5005) = map {
- pack "sss", split m/[._]/, "$_.0.0" } $version, $api_versionstring, "5.005";
-foreach $d (@candidates) {
- if ($d->[1] lt $pversion) {
- if ($d->[1] ge $aversion) {
- unshift(@inc_version_list, grep { -d } $d->[0]."/$archname", $d->[0]);
- }
- elsif ($d->[1] ge $vsn5005) {
- unshift(@inc_version_list, grep { -d } $d->[0]);
- }
- }
- else {
- # Skip newer version. I.e. don't look in
- # 5.7.0 if we're installing 5.6.1.
- }
-}
+: define an is-in-libc? function
+inlibc='echo " "; td=$define; tu=$undef;
+sym=$1; var=$2; eval "was=\$$2";
+tx=yes;
+case "$reuseval$was" in
+true) ;;
+true*) tx=no;;
+esac;
+case "$tx" in
+yes)
+ set $sym tres -f;
+ eval $csym;
+ case "$tres" in
+ true)
+ echo "$sym() found." >&4;
+ case "$was" in $undef) . ./whoa; esac; eval "$var=\$td";;
+ *)
+ echo "$sym() NOT found." >&4;
+ case "$was" in $define) . ./whoa; esac; eval "$var=\$tu";;
+ esac;;
+*)
+ case "$was" in
+ $define) echo "$sym() found." >&4;;
+ *) echo "$sym() NOT found." >&4;;
+ esac;;
+esac'
-if (@inc_version_list) {
- print join(' ', @inc_version_list);
-}
-else {
- # Blank space to preserve value for next Configure run.
- print " ";
+: check for length of double
+echo " "
+case "$doublesize" in
+'')
+ echo "Checking to see how big your double precision numbers are..." >&4
+ $cat >try.c <<EOCP
+#include <stdio.h>
+#$i_stdlib I_STDLIB
+#ifdef I_STDLIB
+#include <stdlib.h>
+#endif
+int main()
+{
+ printf("%d\n", (int)sizeof(double));
+ exit(0);
}
-EOPL
-chmod +x getverlist
-case "$inc_version_list" in
-'') if test -x "$perl5$exe_ext"; then
- dflt=`$perl5 getverlist`
+EOCP
+ set try
+ if eval $compile_ok; then
+ doublesize=`$run ./try`
+ echo "Your double is $doublesize bytes long."
else
- dflt='none'
+ dflt='8'
+ echo "(I can't seem to compile the test program. Guessing...)"
+ rp="What is the size of a double precision number (in bytes)?"
+ . ./myread
+ doublesize="$ans"
fi
;;
-$undef) dflt='none' ;;
-*) eval dflt=\"$inc_version_list\" ;;
-esac
-case "$dflt" in
-''|' ') dflt=none ;;
-esac
-case "$dflt" in
-5.005) dflt=none ;;
-esac
-$cat <<EOM
-
-In order to ease the process of upgrading, this version of perl
-can be configured to use modules built and installed with earlier
-versions of perl that were installed under $prefix. Specify here
-the list of earlier versions that this version of perl should check.
-If Configure detected no earlier versions of perl installed under
-$prefix, then the list will be empty. Answer 'none' to tell perl
-to not search earlier versions.
-
-The default should almost always be sensible, so if you're not sure,
-just accept the default.
-EOM
-
-rp='List of earlier versions to include in @INC?'
-. ./myread
-case "$ans" in
-[Nn]one|''|' '|$undef) inc_version_list=' ' ;;
-*) inc_version_list="$ans" ;;
-esac
-case "$inc_version_list" in
-''|' ')
- inc_version_list_init='0'
- d_inc_version_list="$undef"
- ;;
-*) inc_version_list_init=`echo $inc_version_list |
- $sed -e 's/^/"/' -e 's/ /","/g' -e 's/$/",0/'`
- d_inc_version_list="$define"
- ;;
esac
-$rm -f getverlist
+$rm_try
-: see if malloc/malloc.h has to be included
-set malloc/malloc.h i_mallocmalloc
+: see if this is a float.h system
+set float.h i_float
eval $inhdr
-: see if this is a malloc.h system
-: we want a real compile instead of Inhdr because some systems have a
-: malloc.h that just gives a compile error saying to use stdlib.h instead
+: check for long doubles
echo " "
-$cat >try.c <<EOCP
-#include <stdlib.h>
-#include <malloc.h>
-#$i_mallocmalloc I_MALLOCMALLOC
-#ifdef I_MALLOCMALLOC
-# include <malloc/malloc.h>
-#endif
-
-int main () { return 0; }
-EOCP
+echo "Checking to see if you have long double..." >&4
+echo 'int main() { long double x = 7.0; }' > try.c
set try
if eval $compile; then
- echo "<malloc.h> found." >&4
- val="$define"
+ val="$define"
+ echo "You have long double."
else
- echo "<malloc.h> NOT found." >&4
- val="$undef"
+ val="$undef"
+ echo "You do not have long double."
fi
$rm_try
-set i_malloc
+set d_longdbl
eval $setvar
-: check for length of pointer
-echo " "
-case "$ptrsize" in
-'')
- echo "Checking to see how big your pointers are..." >&4
- $cat >>try.c <<EOCP
+: see if ldexpl exists
+set ldexpl d_ldexpl
+eval $inlibc
+
+: see if this is a quadmath.h system
+set quadmath.h i_quadmath
+eval $inhdr
+
+: check for length of long double
+case "${d_longdbl}${longdblsize}" in
+$define)
+ echo " "
+ echo "Checking to see how big your long doubles are..." >&4
+ $cat >try.c <<'EOCP'
#include <stdio.h>
-#$i_stdlib I_STDLIB
-#ifdef I_STDLIB
-#include <stdlib.h>
-#endif
int main()
{
- printf("%d\n", (int)sizeof(void *));
- exit(0);
+ printf("%d\n", sizeof(long double));
}
EOCP
set try
- if eval $compile_ok; then
- ptrsize=`$run ./try`
- echo "Your pointers are $ptrsize bytes long."
+ set try
+ if eval $compile; then
+ longdblsize=`$run ./try`
+ echo "Your long doubles are $longdblsize bytes long."
else
- dflt='4'
+ dflt='8'
+ echo " "
echo "(I can't seem to compile the test program. Guessing...)" >&4
- rp="What is the size of a pointer (in bytes)?"
+ rp="What is the size of a long double (in bytes)?"
. ./myread
- ptrsize="$ans"
+ longdblsize="$ans"
+ fi
+ if $test "X$doublesize" = "X$longdblsize"; then
+ echo "That isn't any different from an ordinary double."
+ echo "I'll keep your setting anyway, but you may see some"
+ echo "harmless compilation warnings."
+ fi
+ ;;
+esac
+$rm_try
+
+$echo "Checking the kind of long doubles you have..." >&4
+case "$d_longdbl" in
+define)
+$cat <<EOP >try.c
+#$i_float I_FLOAT
+#$i_stdlib I_STDLIB
+#define LONGDBLSIZE $longdblsize
+#ifdef I_FLOAT
+#include <float.h>
+#endif
+#ifdef I_STDLIB
+#include <stdlib.h>
+#endif
+#$usequadmath USE_QUADMATH
+#$i_quadmath I_QUADMATH
+#if defined(USE_QUADMATH) && defined(I_QUADMATH)
+#include <quadmath.h>
+static const __float128 d = -0.1Q;
+#else
+static const long double d = -0.1L;
+#endif
+#include <stdio.h>
+int main() {
+ unsigned const char* b = (unsigned const char*)(&d);
+#if (LDBL_MANT_DIG == 113 || FLT128_MANT_DIG == 113) && LONGDBLSIZE == 16
+ if (b[0] == 0x9A && b[1] == 0x99 && b[15] == 0xBF) {
+ /* IEEE 754 128-bit little-endian */
+ printf("1\n");
+ exit(0);
+ }
+ if (b[0] == 0xBF && b[14] == 0x99 && b[15] == 0x9A) {
+ /* IEEE 128-bit big-endian, e.g. solaris sparc */
+ printf("2\n");
+ exit(0);
+ }
+#endif
+#if LDBL_MANT_DIG == 64 && (LONGDBLSIZE == 16 || LONGDBLSIZE == 12)
+ if (b[0] == 0xCD && b[9] == 0xBF && b[10] == 0x00) {
+ /* x86 80-bit little-endian, sizeof 12 (ILP32, Solaris x86)
+ * or 16 (LP64, Linux and OS X), 4 or 6 bytes of padding.
+ * Also known as "extended precision". */
+ printf("3\n");
+ exit(0);
+ }
+ if (b[0] == 0xBF && b[9] == 0xCD && b[10] == 0x00) {
+ /* is there ever big-endian 80-bit, really? */
+ printf("4\n");
+ exit(0);
+ }
+#endif
+#if LDBL_MANT_DIG == 106 && LONGDBLSIZE == 16
+ /* software "double double", the 106 is 53+53 */
+ if (b[0] == 0x9A && b[7] == 0x3C && b[8] == 0x9A && b[15] == 0xBF) {
+ /* double double 128-bit little-endian,
+ * 9a 99 99 99 99 99 59 3c 9a 99 99 99 99 99 b9 bf */
+ printf("5\n");
+ exit(0);
+ }
+ if (b[0] == 0xBF && b[7] == 0x9A && b[8] == 0x3C && b[15] == 0x9A) {
+ /* double double 128-bit big-endian, e.g. PPC/Power and MIPS:
+ * bf b9 99 99 99 99 99 9a 3c 59 99 99 99 99 99 9a */
+ printf("6\n");
+ exit(0);
+ }
+#endif
+ printf("-1\n"); /* unknown */
+ exit(0);
+}
+EOP
+set try
+if eval $compile; then
+ longdblkind=`$run ./try`
+else
+ longdblkind=-1
+fi
+;;
+*) longdblkind=0 ;;
+esac
+case "$longdblkind" in
+0) echo "Your long doubles are doubles." >&4 ;;
+1) echo "You have IEEE 754 128-bit little endian long doubles." >&4 ;;
+2) echo "You have IEEE 754 128-bit big endian long doubles." >&4 ;;
+3) echo "You have x86 80-bit little endian long doubles." >& 4 ;;
+*) echo "Cannot figure out your long double." >&4 ;;
+esac
+$rm_try
+
+
+: determine the architecture name
+echo " "
+if xxx=`./loc arch blurfl $pth`; $test -f "$xxx"; then
+ tarch=`arch`"-$osname"
+elif xxx=`./loc uname blurfl $pth`; $test -f "$xxx" ; then
+ if uname -m > tmparch 2>&1 ; then
+ tarch=`$sed -e 's/ *$//' -e 's/ /_/g' \
+ -e 's/$/'"-$osname/" tmparch`
+ else
+ tarch="$osname"
fi
+ $rm -f tmparch
+else
+ tarch="$osname"
+fi
+case "$myarchname" in
+''|"$tarch") ;;
+*)
+ echo "(Your architecture name used to be $myarchname.)"
+ archname=''
;;
esac
-$rm_try
-case "$use64bitall" in
-"$define"|true|[yY]*)
- case "$ptrsize" in
- 4) cat <<EOM >&4
+case "$targetarch" in
+'') ;;
+*) archname=`echo $targetarch|sed 's,^[^-]*-,,'` ;;
+esac
+myarchname="$tarch"
+case "$archname" in
+'') dflt="$tarch";;
+*) dflt="$archname";;
+esac
+rp='What is your architecture name'
+. ./myread
+archname="$ans"
+
+: optionally add API version to the architecture for versioned archlibs
+case "$useversionedarchname" in
+$define|true|[yY]*) dflt='y';;
+*) dflt='n';;
+esac
+rp='Add the Perl API version to your archname?'
+. ./myread
+case "$ans" in
+y|Y) useversionedarchname="$define" ;;
+*) useversionedarchname="$undef" ;;
+esac
+case "$useversionedarchname" in
+$define)
+ case "$archname" in
+ *-$api_versionstring)
+ echo "...and architecture name already has -$api_versionstring" >&4
+ ;;
+ *)
+ archname="$archname-$api_versionstring"
+ echo "...setting architecture name to $archname." >&4
+ ;;
+ esac
+ ;;
+esac
-*** You have chosen a maximally 64-bit build,
-*** but your pointers are only 4 bytes wide.
-*** Please rerun Configure without -Duse64bitall.
-EOM
- case "$d_quad" in
- define)
- cat <<EOM >&4
-*** Since you have quads, you could possibly try with -Duse64bitint.
-EOM
- ;;
+case "$usethreads" in
+$define)
+ echo "Threads selected." >&4
+ case "$archname" in
+ *-thread*) echo "...and architecture name already has -thread." >&4
+ ;;
+ *) archname="$archname-thread"
+ echo "...setting architecture name to $archname." >&4
+ ;;
+ esac
+ ;;
+esac
+case "$usemultiplicity" in
+$define)
+ echo "Multiplicity selected." >&4
+ case "$archname" in
+ *-multi*) echo "...and architecture name already has -multi." >&4
+ ;;
+ *) archname="$archname-multi"
+ echo "...setting architecture name to $archname." >&4
+ ;;
+ esac
+ ;;
+esac
+case "$use64bitint$use64bitall" in
+*"$define"*)
+ case "$archname64" in
+ '')
+ echo "This architecture is naturally 64-bit, not changing architecture name." >&4
+ ;;
+ *)
+ case "$use64bitint" in
+ "$define") echo "64 bit integers selected." >&4 ;;
esac
- cat <<EOM >&4
-*** Cannot continue, aborting.
-
-EOM
-
- exit 1
+ case "$use64bitall" in
+ "$define") echo "Maximal 64 bitness selected." >&4 ;;
+ esac
+ case "$archname" in
+ *-$archname64*) echo "...and architecture name already has $archname64." >&4
+ ;;
+ *) archname="$archname-$archname64"
+ echo "...setting architecture name to $archname." >&4
+ ;;
+ esac
+ ;;
+ esac
+esac
+case "$uselongdouble" in
+$define)
+ echo "Long doubles selected." >&4
+ case "$longdblsize" in
+ $doublesize)
+ echo "...but long doubles are equal to doubles, not changing architecture name." >&4
+ ;;
+ *)
+ case "$archname" in
+ *-ld*) echo "...and architecture name already has -ld." >&4
+ ;;
+ *) archname="$archname-ld"
+ echo "...setting architecture name to $archname." >&4
+ ;;
+ esac
;;
esac
;;
esac
+if $test -f archname.cbu; then
+ echo "Your platform has some specific hints for architecture name, using them..."
+ . ./archname.cbu
+fi
+: set the prefixit variable, to compute a suitable default value
+prefixit='case "$3" in
+""|none)
+ case "$oldprefix" in
+ "") eval "$1=\"\$$2\"";;
+ *)
+ case "$3" in
+ "") eval "$1=";;
+ none)
+ eval "tp=\"\$$2\"";
+ case "$tp" in
+ ""|" ") eval "$1=\"\$$2\"";;
+ *) eval "$1=";;
+ esac;;
+ esac;;
+ esac;;
+*)
+ eval "tp=\"$oldprefix-\$$2-\""; eval "tp=\"$tp\"";
+ case "$tp" in
+ --|/*--|\~*--) eval "$1=\"$prefix/$3\"";;
+ /*-$oldprefix/*|\~*-$oldprefix/*)
+ eval "$1=\`echo \$$2 | sed \"s,^$oldprefix,$prefix,\"\`";;
+ *) eval "$1=\"\$$2\"";;
+ esac;;
+esac'
-: determine whether to use malloc wrapping
-echo " "
-case "$usemallocwrap" in
-[yY]*|true|$define) dflt='y' ;;
-[nN]*|false|$undef) dflt='n' ;;
-*) case "$usedevel" in
- [yY]*|true|$define) dflt='y' ;;
- *) dflt='n' ;;
+: determine installation style
+: For now, try to deduce it from prefix unless it is already set.
+: Reproduce behavior of 5.005 and earlier, maybe drop that in 5.7.
+case "$installstyle" in
+'') case "$prefix" in
+ *perl*) dflt='lib';;
+ *) dflt='lib/perl5' ;;
esac
;;
+*) dflt="$installstyle" ;;
esac
-rp="Do you wish to wrap malloc calls to protect against potential overflows?"
-. ./myread
-usemallocwrap="$ans"
-case "$ans" in
-y*|true)
- usemallocwrap="$define" ;;
-*)
- usemallocwrap="$undef" ;;
-esac
+: Probably not worth prompting for this since we prompt for all
+: the directories individually, and the prompt would be too long and
+: confusing anyway.
+installstyle=$dflt
-: determine which malloc to compile in
+: determine where public executables go
echo " "
-case "$usemymalloc" in
-[yY]*|true|$define) dflt='y' ;;
-[nN]*|false|$undef) dflt='n' ;;
-*) case "$ptrsize" in
- 4) dflt='y' ;;
- *) dflt='n' ;;
- esac
- if test "$useithreads" = "$define"; then dflt='n'; fi
- ;;
+set dflt bin bin
+eval $prefixit
+fn=d~
+rp='Pathname where the public executables will reside?'
+. ./getfile
+if $test "X$ansexp" != "X$binexp"; then
+ installbin=''
+fi
+prefixvar=bin
+: XXX Bug? -- ignores Configure -Dinstallprefix setting.
+: XXX If this is fixed, also fix the "start perl" hunk below, which relies on
+: this via initialinstalllocation
+. ./setprefixvar
+
+case "$userelocatableinc" in
+$define|true|[yY]*) dflt='y' ;;
+*) dflt='n' ;;
esac
-rp="Do you wish to attempt to use the malloc that comes with $package?"
+cat <<EOM
+
+Would you like to build Perl so that the installation is relocatable, so that
+library paths in @INC are determined relative to the path of the perl binary?
+This is not advised for system Perl installs, or if you need to run setid
+scripts or scripts under taint mode.
+
+If this doesn't make any sense to you, just accept the default '$dflt'.
+EOM
+rp='Use relocatable @INC?'
. ./myread
-usemymalloc="$ans"
case "$ans" in
-y*|true)
- usemymalloc='y'
- mallocsrc='malloc.c'
- mallocobj="malloc$_o"
- d_mymalloc="$define"
- case "$libs" in
- *-lmalloc*)
- : Remove malloc from list of libraries to use
- echo "Removing unneeded -lmalloc from library list" >&4
- set `echo X $libs | $sed -e 's/-lmalloc / /' -e 's/-lmalloc$//'`
- shift
- libs="$*"
- echo "libs = $libs" >&4
- ;;
- esac
- ;;
-*)
- usemymalloc='n'
- mallocsrc=''
- mallocobj=''
- d_mymalloc="$undef"
- ;;
+y|Y) val="$define" ;;
+*) val="$undef" ;;
esac
+set userelocatableinc
+eval $setvar
-: compute the return types of malloc and free
-echo " "
-$cat >malloc.c <<END
-#$i_malloc I_MALLOC
-#$i_stdlib I_STDLIB
-#include <stdio.h>
-#include <sys/types.h>
-#ifdef I_MALLOC
-#include <malloc.h>
-#endif
-#ifdef I_STDLIB
-#include <stdlib.h>
-#endif
-#ifdef TRY_MALLOC
-void *malloc();
-#endif
-#ifdef TRY_FREE
-void free();
-#endif
-END
-case "$malloctype" in
-'')
- if $cc $ccflags -c -DTRY_MALLOC malloc.c >/dev/null 2>&1; then
- malloctype='void *'
- else
- malloctype='char *'
- fi
- ;;
+initialinstalllocation="$binexp"
+: Default prefix is now "up one level from where the binaries are"
+case "$userelocatableinc" in
+$define|true|[yY]*)
+ bin=".../"
+ binexp=".../"
+ prefix=".../.."
+ prefixexp=".../.."
+ installprefixexp=".../.."
+ ;;
esac
-echo "Your system wants malloc to return '$malloctype', it would seem." >&4
-case "$freetype" in
-'')
- if $cc $ccflags -c -DTRY_FREE malloc.c >/dev/null 2>&1; then
- freetype='void'
- else
- freetype='int'
- fi
- ;;
-esac
-echo "Your system uses $freetype free(), it would seem." >&4
-$rm -f malloc.[co]
-: determine where site specific architecture-dependent libraries go.
-: sitelib default is /usr/local/lib/perl5/site_perl/$version
-: sitearch default is /usr/local/lib/perl5/site_perl/$version/$archname
-: sitelib may have an optional trailing /share.
-case "$sitearch" in
-'') dflt=`echo $sitelib | $sed 's,/share$,,'`
- dflt="$dflt/$archname"
- ;;
-*) dflt="$sitearch"
- ;;
+: determine where private library files go
+: Usual default is /usr/local/lib/perl5/$version.
+: Also allow things like /opt/perl/lib/$version, since
+: /opt/perl/lib/perl5... would be redundant.
+: The default "style" setting is made in installstyle.U
+case "$installstyle" in
+*lib/perl5*) set dflt privlib lib/$package/$version ;;
+*) set dflt privlib lib/$version ;;
esac
-set sitearch sitearch none
eval $prefixit
$cat <<EOM
-The installation process will also create a directory for
-architecture-dependent site-specific extensions and modules.
+There are some auxiliary files for $package that need to be put into a
+private library directory that is accessible by everyone.
EOM
+fn=$binexp
fn=d~+
-rp='Pathname for the site-specific architecture-dependent library files?'
+rp='Pathname where the private library files will reside?'
. ./getfile
-prefixvar=sitearch
+prefixvar=privlib
. ./setprefixvar
-if $test X"$sitearch" = X"$sitelib"; then
- d_sitearch="$undef"
+
+: set the prefixup variable, to restore leading tilda escape
+prefixup='case "$prefixexp" in
+"$prefix") ;;
+*) eval "$1=\`echo \$$1 | sed \"s,^$prefixexp,$prefix,\"\`";;
+esac'
+
+: determine where public architecture dependent libraries go
+set archlib archlib
+eval $prefixit
+: privlib default is /usr/local/lib/$package/$version
+: archlib default is /usr/local/lib/$package/$version/$archname
+: privlib may have an optional trailing /share.
+tdflt=`echo $privlib | $sed 's,/share$,,'`
+tdflt=$tdflt/$archname
+case "$archlib" in
+'') dflt=$tdflt
+ ;;
+*) dflt="$archlib"
+ ;;
+esac
+$cat <<EOM
+
+$spackage contains architecture-dependent library files. If you are
+sharing libraries in a heterogeneous environment, you might store
+these files in a separate location. Otherwise, you can just include
+them with the rest of the public library files.
+
+EOM
+fn=$binexp
+fn=d+~
+rp='Where do you want to put the public architecture-dependent libraries?'
+. ./getfile
+prefixvar=archlib
+. ./setprefixvar
+if $test X"$archlib" = X"$privlib"; then
+ d_archlib="$undef"
else
- d_sitearch="$define"
+ d_archlib="$define"
fi
-: Set the vendorprefix variables
+: see if setuid scripts can be secure
$cat <<EOM
-The installation process will also create a directory for
-vendor-supplied add-ons. Vendors who supply perl with their system
-may find it convenient to place all vendor-supplied files in this
-directory rather than in the main distribution directory. This will
-ease upgrades between binary-compatible maintenance versions of perl.
+Some kernels have a bug that prevents setuid #! scripts from being
+secure. Some sites have disabled setuid #! scripts because of this.
-Of course you may also use these directories in whatever way you see
-fit. For example, you might use them to access modules shared over a
-company-wide network.
+First let's decide if your kernel supports secure setuid #! scripts.
+(If setuid #! scripts would be secure but have been disabled anyway,
+don't say that they are secure if asked.)
-The default answer should be fine for most people.
-This causes further questions about vendor add-ons to be skipped
-and no vendor-specific directories will be configured for perl.
+EOM
+
+val="$undef"
+if $test -d /dev/fd; then
+ echo "#!$ls" >reflect
+ chmod +x,u+s reflect
+ ./reflect >flect 2>&1
+ if $contains "/dev/fd" flect >/dev/null; then
+ echo "Congratulations, your kernel has secure setuid scripts!" >&4
+ val="$define"
+ else
+ $cat <<EOM
+If you are not sure if they are secure, I can check but I'll need a
+username and password different from the one you are using right now.
+If you don't have such a username or don't want me to test, simply
+enter 'none'.
EOM
-rp='Do you want to configure vendor-specific add-on directories?'
-case "$usevendorprefix" in
-define|true|[yY]*) dflt=y ;;
-*) : User may have set vendorprefix directly on Configure command line.
- case "$vendorprefix" in
- ''|' ') dflt=n ;;
- *) dflt=y ;;
- esac
+ rp='Other username to test security of setuid scripts with?'
+ dflt='none'
+ . ./myread
+ case "$ans" in
+ n|none)
+ case "$d_suidsafe" in
+ '') echo "I'll assume setuid scripts are *not* secure." >&4
+ dflt=n;;
+ "$undef")
+ echo "Well, the $hint value is *not* secure." >&4
+ dflt=n;;
+ *) echo "Well, the $hint value *is* secure." >&4
+ dflt=y;;
+ esac
+ ;;
+ *)
+ $rm -f reflect flect
+ echo "#!$ls" >reflect
+ chmod +x,u+s reflect
+ echo >flect
+ chmod a+w flect
+ echo '"su" will (probably) prompt you for '"$ans's password."
+ su $ans -c './reflect >flect'
+ if $contains "/dev/fd" flect >/dev/null; then
+ echo "Okay, it looks like setuid scripts are secure." >&4
+ dflt=y
+ else
+ echo "I don't think setuid scripts are secure." >&4
+ dflt=n
+ fi
+ ;;
+ esac
+ rp='Does your kernel have *secure* setuid scripts?'
+ . ./myread
+ case "$ans" in
+ [yY]*) val="$define";;
+ *) val="$undef";;
+ esac
+ fi
+else
+ echo "I don't think setuid scripts are secure (no /dev/fd directory)." >&4
+ echo "(That's for file descriptors, not floppy disks.)"
+ val="$undef"
+fi
+set d_suidsafe
+eval $setvar
+
+$rm -f reflect flect
+
+: now see if they want to do setuid emulation
+if $test $patchlevel -lt 11; then
+echo " "
+val="$undef"
+case "$d_suidsafe" in
+"$define")
+ val="$undef"
+ echo "No need to emulate SUID scripts since they are secure here." >&4
;;
-esac
-. ./myread
-case "$ans" in
-[yY]*) fn=d~+
- rp='Installation prefix to use for vendor-supplied add-ons?'
- case "$vendorprefix" in
- '') dflt="$prefix" ;;
- *) dflt=$vendorprefix ;;
+*)
+ $cat <<EOM
+Some systems have disabled setuid scripts, especially systems where
+setuid scripts cannot be secure. On systems where setuid scripts have
+been disabled, the setuid/setgid bits on scripts are currently
+useless. It is possible for $package to detect those bits and emulate
+setuid/setgid in a secure fashion. This emulation will only work if
+setuid scripts have been disabled in your kernel.
+
+EOM
+ case "$d_dosuid" in
+ "$define") dflt=y ;;
+ *) dflt=n ;;
esac
- . ./getfile
- : XXX Prefixit unit does not yet support siteprefix and vendorprefix
- oldvendorprefix=''
- case "$vendorprefix" in
- '') ;;
- *) case "$ans" in
- "$prefix") ;;
- *) oldvendorprefix="$prefix";;
- esac
- ;;
+ rp="Do you want to do setuid/setgid emulation?"
+ . ./myread
+ case "$ans" in
+ [yY]*) val="$define";;
+ *) val="$undef";;
esac
- usevendorprefix="$define"
- vendorprefix="$ans"
- vendorprefixexp="$ansexp"
;;
-*) usevendorprefix="$undef"
- vendorprefix=''
- vendorprefixexp=''
+esac
+set d_dosuid
+eval $setvar
+else
+ case "$d_dosuid" in
+ "$define")
+ cat >&4 <<EOH
+
+SUID emulation has been removed for 5.12
+Please re-run Configure without -Dd_dosuid
+
+EOH
+ exit 1;
+ ;;
+ esac
+ d_dosuid=undef
+fi
+
+: Find perl5.005 or later.
+echo "Looking for a previously installed perl5.005 or later... "
+case "$perl5" in
+'') for tdir in `echo "$binexp$path_sep$PATH" | $sed "s/$path_sep/ /g"`; do
+ : Check if this perl is recent and can load a simple module
+ if $test -x $tdir/perl$exe_ext && $tdir/perl -Mless -e 'use 5.005;' >/dev/null 2>&1; then
+ perl5=$tdir/perl
+ break;
+ elif $test -x $tdir/perl5$exe_ext && $tdir/perl5 -Mless -e 'use 5.005;' >/dev/null 2>&1; then
+ perl5=$tdir/perl5
+ break;
+ fi
+ done
+ ;;
+*) perl5="$perl5"
;;
esac
+case "$perl5" in
+'') echo "None found. That's ok.";;
+*) echo "Using $perl5." ;;
+esac
-: Set the vendorlib variables
-case "$vendorprefix" in
-'') d_vendorlib="$undef"
- vendorlib=''
- vendorlibexp=''
- ;;
-*) d_vendorlib="$define"
- : determine where vendor-supplied modules go.
- : Usual default is /usr/local/lib/perl5/vendor_perl/$version
- case "$vendorlib" in
- '')
- prog=`echo $package | $sed 's/-*[0-9.]*$//'`
- case "$installstyle" in
- *lib/perl5*) dflt=$vendorprefix/lib/$package/vendor_$prog/$version ;;
- *) dflt=$vendorprefix/lib/vendor_$prog/$version ;;
- esac
- ;;
- *) dflt="$vendorlib"
- ;;
+: Set the siteprefix variables
+$cat <<EOM
+
+After $package is installed, you may wish to install various
+add-on modules and utilities. Typically, these add-ons will
+be installed under $prefix with the rest
+of this package. However, you may wish to install such add-ons
+elsewhere under a different prefix.
+
+If you do not wish to put everything under a single prefix, that's
+ok. You will be prompted for the individual locations; this siteprefix
+is only used to suggest the defaults.
+
+The default should be fine for most people.
+
+EOM
+fn=d~+
+rp='Installation prefix to use for add-on modules and utilities?'
+: XXX Here might be another good place for an installstyle setting.
+case "$siteprefix" in
+'') dflt=$prefix ;;
+*) dflt=$siteprefix ;;
+esac
+. ./getfile
+: XXX Prefixit unit does not yet support siteprefix and vendorprefix
+oldsiteprefix=''
+case "$siteprefix" in
+'') ;;
+*) case "$ans" in
+ "$prefix") ;;
+ *) oldsiteprefix="$prefix";;
esac
- fn=d~+
- rp='Pathname for the vendor-supplied library files?'
- . ./getfile
- vendorlib="$ans"
- vendorlibexp="$ansexp"
;;
esac
-vendorlib_stem=`echo "$vendorlibexp" | sed "s,/$version$,,"`
-prefixvar=vendorlib
-. ./installprefix
+siteprefix="$ans"
+siteprefixexp="$ansexp"
-: Set the vendorarch variables
-case "$vendorprefix" in
-'') d_vendorarch="$undef"
- vendorarch=''
- vendorarchexp=''
- ;;
-*) d_vendorarch="$define"
- : determine where vendor-supplied architecture-dependent libraries go.
- : vendorlib default is /usr/local/lib/perl5/vendor_perl/$version
- : vendorarch default is /usr/local/lib/perl5/vendor_perl/$version/$archname
- : vendorlib may have an optional trailing /share.
- case "$vendorarch" in
- '') dflt=`echo $vendorlib | $sed 's,/share$,,'`
- dflt="$dflt/$archname"
- ;;
- *) dflt="$vendorarch" ;;
+: determine where site specific libraries go.
+: Usual default is /usr/local/lib/perl5/site_perl/$version
+: The default "style" setting is made in installstyle.U
+: XXX No longer works with Prefixit stuff.
+prog=`echo $package | $sed 's/-*[0-9.]*$//'`
+case "$sitelib" in
+'') case "$installstyle" in
+ *lib/perl5*) dflt=$siteprefix/lib/$package/site_$prog/$version ;;
+ *) dflt=$siteprefix/lib/site_$prog/$version ;;
esac
- fn=d~+
- rp='Pathname for vendor-supplied architecture-dependent files?'
- . ./getfile
- vendorarch="$ans"
- vendorarchexp="$ansexp"
+ ;;
+*) dflt="$sitelib"
;;
esac
-prefixvar=vendorarch
-. ./installprefix
-if $test X"$vendorarch" = X"$vendorlib"; then
- d_vendorarch="$undef"
-else
- d_vendorarch="$define"
-fi
-
-: Final catch-all directories to search
$cat <<EOM
-Lastly, you can have perl look in other directories for extensions and
-modules in addition to those already specified.
-These directories will be searched after
- $sitearch
- $sitelib
+The installation process will create a directory for
+site-specific extensions and modules. Most users find it convenient
+to place all site-specific files in this directory rather than in the
+main distribution directory.
+
EOM
-test X"$vendorlib" != "X" && echo ' ' $vendorlib
-test X"$vendorarch" != "X" && echo ' ' $vendorarch
-echo ' '
-case "$otherlibdirs" in
-''|' ') dflt='none' ;;
-*) dflt="$otherlibdirs" ;;
+fn=d~+
+rp='Pathname for the site-specific library files?'
+. ./getfile
+prefixvar=sitelib
+. ./setprefixvar
+sitelib_stem=`echo "$sitelibexp" | sed "s,/$version$,,"`
+
+: Determine list of previous versions to include in @INC
+$cat > getverlist <<EOPL
+#!$perl5 -w
+use File::Basename;
+\$api_versionstring = "$api_versionstring";
+\$version = "$version";
+\$stem = "$sitelib_stem";
+\$archname = "$archname";
+EOPL
+ $cat >> getverlist <<'EOPL'
+# The list found is store twice for each entry: the original name, and
+# the binary broken down version as pack "sss", so sorting is easy and
+# unambiguous. This will work for all versions that have a maximum of
+# three digit groups, separate by '.'s or '_'s. Names are extended with
+# ".0.0" to ensure at least three elements for the pack.
+# -- H.Merijn Brand (m)'06 23-10-2006
+
+# Can't have leading @ because metaconfig interprets it as a command!
+;@inc_version_list=();
+# XXX Redo to do opendir/readdir?
+if (-d $stem) {
+ chdir($stem);
+ ;@candidates = map {
+ [ $_, pack "sss", split m/[._]/, "$_.0.0" ] } glob("5.*");
+ ;@candidates = sort { $a->[1] cmp $b->[1]} @candidates;
+}
+else {
+ ;@candidates = ();
+}
+
+($pversion, $aversion, $vsn5005) = map {
+ pack "sss", split m/[._]/, "$_.0.0" } $version, $api_versionstring, "5.005";
+foreach $d (@candidates) {
+ if ($d->[1] lt $pversion) {
+ if ($d->[1] ge $aversion) {
+ unshift(@inc_version_list, grep { -d } $d->[0]."/$archname", $d->[0]);
+ }
+ elsif ($d->[1] ge $vsn5005) {
+ unshift(@inc_version_list, grep { -d } $d->[0]);
+ }
+ }
+ else {
+ # Skip newer version. I.e. don't look in
+ # 5.7.0 if we're installing 5.6.1.
+ }
+}
+
+if (@inc_version_list) {
+ print join(' ', @inc_version_list);
+}
+else {
+ # Blank space to preserve value for next Configure run.
+ print " ";
+}
+EOPL
+chmod +x getverlist
+case "$inc_version_list" in
+'') if test -x "$perl5$exe_ext"; then
+ dflt=`$perl5 getverlist`
+ else
+ dflt='none'
+ fi
+ ;;
+$undef) dflt='none' ;;
+*) eval dflt=\"$inc_version_list\" ;;
+esac
+case "$dflt" in
+''|' ') dflt=none ;;
+esac
+case "$dflt" in
+5.005) dflt=none ;;
esac
$cat <<EOM
-Enter a colon-separated set of extra paths to include in perl's @INC
-search path, or enter 'none' for no extra paths.
+In order to ease the process of upgrading, this version of perl
+can be configured to use modules built and installed with earlier
+versions of perl that were installed under $prefix. Specify here
+the list of earlier versions that this version of perl should check.
+If Configure detected no earlier versions of perl installed under
+$prefix, then the list will be empty. Answer 'none' to tell perl
+to not search earlier versions.
+
+The default should almost always be sensible, so if you're not sure,
+just accept the default.
EOM
-rp='Colon-separated list of additional directories for perl to search?'
+rp='List of earlier versions to include in @INC?'
. ./myread
case "$ans" in
-' '|''|none) otherlibdirs=' ' ;;
-*) otherlibdirs="$ans" ;;
+[Nn]one|''|' '|$undef) inc_version_list=' ' ;;
+*) inc_version_list="$ans" ;;
esac
-case "$otherlibdirs" in
-' ') val=$undef ;;
-*) val=$define ;;
+case "$inc_version_list" in
+''|' ')
+ inc_version_list_init='0'
+ d_inc_version_list="$undef"
+ ;;
+*) inc_version_list_init=`echo $inc_version_list |
+ $sed -e 's/^/"/' -e 's/ /","/g' -e 's/$/",0/'`
+ d_inc_version_list="$define"
+ ;;
esac
-set d_perl_otherlibdirs
+$rm -f getverlist
+
+: see if malloc/malloc.h has to be included
+set malloc/malloc.h i_mallocmalloc
+eval $inhdr
+
+: see if this is a malloc.h system
+: we want a real compile instead of Inhdr because some systems have a
+: malloc.h that just gives a compile error saying to use stdlib.h instead
+echo " "
+$cat >try.c <<EOCP
+#include <stdlib.h>
+#include <malloc.h>
+#$i_mallocmalloc I_MALLOCMALLOC
+#ifdef I_MALLOCMALLOC
+# include <malloc/malloc.h>
+#endif
+
+int main () { return 0; }
+EOCP
+set try
+if eval $compile; then
+ echo "<malloc.h> found." >&4
+ val="$define"
+else
+ echo "<malloc.h> NOT found." >&4
+ val="$undef"
+fi
+$rm_try
+set i_malloc
eval $setvar
-: Cruising for prototypes
+: check for length of pointer
echo " "
-echo "Checking out function prototypes..." >&4
-$cat >prototype.c <<EOCP
+case "$ptrsize" in
+'')
+ echo "Checking to see how big your pointers are..." >&4
+ $cat >>try.c <<EOCP
+#include <stdio.h>
#$i_stdlib I_STDLIB
#ifdef I_STDLIB
#include <stdlib.h>
#endif
-int main(int argc, char *argv[]) {
- exit(0);}
+int main()
+{
+ printf("%d\n", (int)sizeof(void *));
+ exit(0);
+}
EOCP
-if $cc $ccflags -c prototype.c >prototype.out 2>&1 ; then
- echo "Your C compiler appears to support function prototypes."
- val="$define"
-else
- echo "Your C compiler doesn't seem to understand function prototypes."
- val="$undef"
-fi
-set prototype
-eval $setvar
-$rm -f prototype*
-
-: Check if ansi2knr is required
-case "$prototype" in
-"$define") ;;
-*) ansi2knr='ansi2knr'
- echo " "
- cat <<EOM >&4
-
-$me: FATAL ERROR:
-This version of $package can only be compiled by a compiler that
-understands function prototypes. Unfortunately, your C compiler
- $cc $ccflags
-doesn't seem to understand them. Sorry about that.
-
-If GNU cc is available for your system, perhaps you could try that instead.
-
-Eventually, we hope to support building Perl with pre-ANSI compilers.
-If you would like to help in that effort, please contact <perlbug@perl.org>.
-
-Aborting Configure now.
-EOM
- exit 2
+ set try
+ if eval $compile_ok; then
+ ptrsize=`$run ./try`
+ echo "Your pointers are $ptrsize bytes long."
+ else
+ dflt='4'
+ echo "(I can't seem to compile the test program. Guessing...)" >&4
+ rp="What is the size of a pointer (in bytes)?"
+ . ./myread
+ ptrsize="$ans"
+ fi
;;
esac
+$rm_try
+case "$use64bitall" in
+"$define"|true|[yY]*)
+ case "$ptrsize" in
+ 4) cat <<EOM >&4
-: DTrace support
-dflt_dtrace='/usr/sbin/dtrace'
-$test -x /usr/bin/dtrace && dflt_dtrace='/usr/bin/dtrace'
-
-cat <<EOM
-
-Perl can be built to support DTrace on platforms that support it.
-DTrace is a diagnosis and performance analysis tool from Sun.
-
-If this doesn't make any sense to you, just accept the default '$dflt'.
+*** You have chosen a maximally 64-bit build,
+*** but your pointers are only 4 bytes wide.
+*** Please rerun Configure without -Duse64bitall.
EOM
-
-while $test 1 ; do
- case "$usedtrace" in
- $define|true|[yY]*)
- dflt='y'
- ;;
- ?*)
- dflt='y'
- dflt_dtrace=$usedtrace
- ;;
- *)
- dflt='n'
- ;;
- esac
-
- rp='Support DTrace if available?'
- . ./myread
- case "$ans" in
- y|Y) val="$define" ;;
- *) val="$undef" ;;
- esac
- set usedtrace
- eval $setvar
-
- test "X$usedtrace" != "X$define" && break
-
- echo " "
- rp='Where is the dtrace executable?'
- dflt=$dflt_dtrace
- . ./getfile
- val="$ans"
- set dtrace
- eval $setvar
-
- if $test -f $dtrace
- then
- if $dtrace -h -s ../perldtrace.d \
- -o perldtrace.tmp >/dev/null 2>&1 \
- && rm -f perldtrace.tmp
- then
- echo " "
- echo "Good: your $dtrace knows about the -h flag."
- else
- cat >&2 <<EOM
-
-*** $me: Fatal Error: $dtrace doesn't support -h flag
-***
-*** Your installed dtrace doesn't support the -h switch to compile a D
-*** program into a C header. Can't continue.
-
+ case "$d_quad" in
+ define)
+ cat <<EOM >&4
+*** Since you have quads, you could possibly try with -Duse64bitint.
EOM
- exit 1
- fi
- break;
- fi
-
- case "$fastread" in
- yes)
- cat >&2 <<EOM
-
-*** $me: Fatal Error: $dtrace not found.
-*** Can't continue.
+ ;;
+ esac
+ cat <<EOM >&4
+*** Cannot continue, aborting.
EOM
+
exit 1
;;
- *)
- echo "*** $dtrace was not found."
- echo " "
- ;;
esac
-done
-
-: See if we want extra modules installed
-echo " "
-case "$extras" in
-'') dflt='n';;
-*) dflt='y';;
+ ;;
esac
-cat <<EOM
-Perl can be built with extra modules or bundles of modules which
-will be fetched from the CPAN and installed alongside Perl.
-Notice that you will need access to the CPAN; either via the Internet,
-or a local copy, for example a CD-ROM or a local CPAN mirror. (You will
-be asked later to configure the CPAN.pm module which will in turn do
-the installation of the rest of the extra modules or bundles.)
-Notice also that if the modules require any external software such as
-libraries and headers (the libz library and the zlib.h header for the
-Compress::Zlib module, for example) you MUST have any such software
-already installed, this configuration process will NOT install such
-things for you.
+: determine whether to use malloc wrapping
+echo " "
+case "$usemallocwrap" in
+[yY]*|true|$define) dflt='y' ;;
+[nN]*|false|$undef) dflt='n' ;;
+*) case "$usedevel" in
+ [yY]*|true|$define) dflt='y' ;;
+ *) dflt='n' ;;
+ esac
+ ;;
+esac
+rp="Do you wish to wrap malloc calls to protect against potential overflows?"
+. ./myread
+usemallocwrap="$ans"
+case "$ans" in
+y*|true)
+ usemallocwrap="$define" ;;
+*)
+ usemallocwrap="$undef" ;;
+esac
-If this doesn't make any sense to you, just accept the default '$dflt'.
-EOM
-rp='Install any extra modules (y or n)?'
+: determine which malloc to compile in
+echo " "
+case "$usemymalloc" in
+[yY]*|true|$define) dflt='y' ;;
+[nN]*|false|$undef) dflt='n' ;;
+*) case "$ptrsize" in
+ 4) dflt='y' ;;
+ *) dflt='n' ;;
+ esac
+ if test "$useithreads" = "$define"; then dflt='n'; fi
+ ;;
+esac
+rp="Do you wish to attempt to use the malloc that comes with $package?"
. ./myread
+usemymalloc="$ans"
case "$ans" in
-y|Y)
- cat <<EOM
+y*|true)
+ usemymalloc='y'
+ mallocsrc='malloc.c'
+ mallocobj="malloc$_o"
+ d_mymalloc="$define"
+ case "$libs" in
+ *-lmalloc*)
+ : Remove malloc from list of libraries to use
+ echo "Removing unneeded -lmalloc from library list" >&4
+ set `echo X $libs | $sed -e 's/-lmalloc / /' -e 's/-lmalloc$//'`
+ shift
+ libs="$*"
+ echo "libs = $libs" >&4
+ ;;
+ esac
+ ;;
+*)
+ usemymalloc='n'
+ mallocsrc=''
+ mallocobj=''
+ d_mymalloc="$undef"
+ ;;
+esac
+
+: compute the return types of malloc and free
+echo " "
+$cat >malloc.c <<END
+#$i_malloc I_MALLOC
+#$i_stdlib I_STDLIB
+#include <stdio.h>
+#include <sys/types.h>
+#ifdef I_MALLOC
+#include <malloc.h>
+#endif
+#ifdef I_STDLIB
+#include <stdlib.h>
+#endif
+#ifdef TRY_MALLOC
+void *malloc();
+#endif
+#ifdef TRY_FREE
+void free();
+#endif
+END
+case "$malloctype" in
+'')
+ if $cc $ccflags -c -DTRY_MALLOC malloc.c >/dev/null 2>&1; then
+ malloctype='void *'
+ else
+ malloctype='char *'
+ fi
+ ;;
+esac
+echo "Your system wants malloc to return '$malloctype', it would seem." >&4
-Please list any extra modules or bundles to be installed from CPAN,
-with spaces between the names. The names can be in any format the
-'install' command of CPAN.pm will understand. (Answer 'none',
-without the quotes, to install no extra modules or bundles.)
-EOM
- rp='Extras?'
- dflt="$extras"
- . ./myread
- extras="$ans"
+case "$freetype" in
+'')
+ if $cc $ccflags -c -DTRY_FREE malloc.c >/dev/null 2>&1; then
+ freetype='void'
+ else
+ freetype='int'
+ fi
+ ;;
esac
-case "$extras" in
-''|'none')
- val=''
- $rm -f ../extras.lst
+echo "Your system uses $freetype free(), it would seem." >&4
+$rm -f malloc.[co]
+: determine where site specific architecture-dependent libraries go.
+: sitelib default is /usr/local/lib/perl5/site_perl/$version
+: sitearch default is /usr/local/lib/perl5/site_perl/$version/$archname
+: sitelib may have an optional trailing /share.
+case "$sitearch" in
+'') dflt=`echo $sitelib | $sed 's,/share$,,'`
+ dflt="$dflt/$archname"
;;
-*) echo "(Saving the list of extras for later...)"
- echo "$extras" > ../extras.lst
- val="'$extras'"
+*) dflt="$sitearch"
;;
esac
-set extras
-eval $setvar
-echo " "
-
-: determine where html pages for programs go
-set html1dir html1dir none
+set sitearch sitearch none
eval $prefixit
$cat <<EOM
-If you wish to install html files for programs in $spackage, indicate
-the appropriate directory here. To skip installing html files,
-answer "none".
-EOM
-case "$html1dir" in
-''|none|$undef|' ') dflt=none ;;
-*) dflt=$html1dir ;;
-esac
-fn=dn+~
-rp="Directory for the main $spackage html pages?"
-. ./getfile
-prefixvar=html1dir
-. ./setprefixvar
-: Use ' ' for none so value is preserved next time through Configure
-$test X"$html1dir" = "X" && html1dir=' '
-
-: determine where html pages for libraries and modules go
-set html3dir html3dir none
-eval $prefixit
-$cat <<EOM
+The installation process will also create a directory for
+architecture-dependent site-specific extensions and modules.
-If you wish to install html files for modules associated with $spackage,
-indicate the appropriate directory here. To skip installing html files,
-answer "none".
EOM
-: There is no obvious default. If they have specified html1dir, then
-: try to key off that, possibly changing .../html1 into .../html3.
-case "$html3dir" in
-'') html3dir=`echo "$html1dir" | $sed 's/1$/3$/'` ;;
-*) dflt=$html3dir ;;
-esac
-fn=dn+~
-rp="Directory for the $spackage module html pages?"
+fn=d~+
+rp='Pathname for the site-specific architecture-dependent library files?'
. ./getfile
-prefixvar=html3dir
+prefixvar=sitearch
. ./setprefixvar
-: Use ' ' for none so value is preserved next time through Configure
-$test X"$html3dir" = "X" && html3dir=' '
-
-: determine whether to install perl also as /usr/bin/perl
-
-echo " "
-if $test -d /usr/bin -a "X$installbin" != X/usr/bin; then
- $cat <<EOM
-Many scripts expect perl to be installed as /usr/bin/perl.
+if $test X"$sitearch" = X"$sitelib"; then
+ d_sitearch="$undef"
+else
+ d_sitearch="$define"
+fi
-If you want to, I can install the perl you are about to compile
-as /usr/bin/perl (in addition to $bin/perl).
-EOM
- if test -f /usr/bin/perl; then
- $cat <<EOM
+: Set the vendorprefix variables
+$cat <<EOM
-However, please note that because you already have a /usr/bin/perl,
-overwriting that with a new Perl would very probably cause problems.
-Therefore I'm assuming you don't want to do that (unless you insist).
+The installation process will also create a directory for
+vendor-supplied add-ons. Vendors who supply perl with their system
+may find it convenient to place all vendor-supplied files in this
+directory rather than in the main distribution directory. This will
+ease upgrades between binary-compatible maintenance versions of perl.
-EOM
- case "$installusrbinperl" in
- "$define"|[yY]*) dflt='y';;
- *) dflt='n';;
- esac
- else
- $cat <<EOM
+Of course you may also use these directories in whatever way you see
+fit. For example, you might use them to access modules shared over a
+company-wide network.
-Since you don't have a /usr/bin/perl I'm assuming creating one is okay.
+The default answer should be fine for most people.
+This causes further questions about vendor add-ons to be skipped
+and no vendor-specific directories will be configured for perl.
EOM
- case "$installusrbinperl" in
- "$undef"|[nN]*) dflt='n';;
- *) dflt='y';;
- esac
- fi
- rp="Do you want to install perl as /usr/bin/perl?"
- . ./myread
- case "$ans" in
- [yY]*) val="$define";;
- *) val="$undef" ;;
+rp='Do you want to configure vendor-specific add-on directories?'
+case "$usevendorprefix" in
+define|true|[yY]*) dflt=y ;;
+*) : User may have set vendorprefix directly on Configure command line.
+ case "$vendorprefix" in
+ ''|' ') dflt=n ;;
+ *) dflt=y ;;
esac
-else
- val="$undef"
-fi
-set installusrbinperl
-eval $setvar
-
-: Check if we are using the GNU C library
-echo " "
-echo "Checking for GNU C Library..." >&4
-cat >try.c <<'EOCP'
-/* Find out version of GNU C library. __GLIBC__ and __GLIBC_MINOR__
- alone are insufficient to distinguish different versions, such as
- 2.0.6 and 2.0.7. The function gnu_get_libc_version() appeared in
- libc version 2.1.0. A. Dougherty, June 3, 2002.
-*/
-#include <stdio.h>
-int main(void)
-{
-#ifdef __GLIBC__
-# ifdef __GLIBC_MINOR__
-# if __GLIBC__ >= 2 && __GLIBC_MINOR__ >= 1 && !defined(__cplusplus)
-# include <gnu/libc-version.h>
- printf("%s\n", gnu_get_libc_version());
-# else
- printf("%d.%d\n", __GLIBC__, __GLIBC_MINOR__);
-# endif
-# else
- printf("%d\n", __GLIBC__);
-# endif
- return 0;
-#else
- return 1;
-#endif
-}
-EOCP
-set try
-if eval $compile_ok && $run ./try > glibc.ver; then
- val="$define"
- gnulibc_version=`$cat glibc.ver`
- echo "You are using the GNU C Library version $gnulibc_version"
-else
- val="$undef"
- gnulibc_version=''
- echo "You are not using the GNU C Library"
-fi
-$rm_try glibc.ver
-set d_gnulibc
-eval $setvar
-
-: see if nm is to be used to determine whether a symbol is defined or not
-case "$usenm" in
-'')
- dflt=''
- case "$d_gnulibc" in
- "$define")
- echo " "
- echo "nm probably won't work on the GNU C Library." >&4
- dflt=n
+ ;;
+esac
+. ./myread
+case "$ans" in
+[yY]*) fn=d~+
+ rp='Installation prefix to use for vendor-supplied add-ons?'
+ case "$vendorprefix" in
+ '') dflt="$prefix" ;;
+ *) dflt=$vendorprefix ;;
+ esac
+ . ./getfile
+ : XXX Prefixit unit does not yet support siteprefix and vendorprefix
+ oldvendorprefix=''
+ case "$vendorprefix" in
+ '') ;;
+ *) case "$ans" in
+ "$prefix") ;;
+ *) oldvendorprefix="$prefix";;
+ esac
;;
esac
- case "$dflt" in
- '')
- if $test "$osname" = aix -a "X$PASE" != "Xdefine" -a ! -f /lib/syscalls.exp; then
- echo " "
- echo "Whoops! This is an AIX system without /lib/syscalls.exp!" >&4
- echo "'nm' won't be sufficient on this system." >&4
- dflt=n
- fi
+ usevendorprefix="$define"
+ vendorprefix="$ans"
+ vendorprefixexp="$ansexp"
+ ;;
+*) usevendorprefix="$undef"
+ vendorprefix=''
+ vendorprefixexp=''
+ ;;
+esac
+
+: Set the vendorlib variables
+case "$vendorprefix" in
+'') d_vendorlib="$undef"
+ vendorlib=''
+ vendorlibexp=''
+ ;;
+*) d_vendorlib="$define"
+ : determine where vendor-supplied modules go.
+ : Usual default is /usr/local/lib/perl5/vendor_perl/$version
+ case "$vendorlib" in
+ '')
+ prog=`echo $package | $sed 's/-*[0-9.]*$//'`
+ case "$installstyle" in
+ *lib/perl5*) dflt=$vendorprefix/lib/$package/vendor_$prog/$version ;;
+ *) dflt=$vendorprefix/lib/vendor_$prog/$version ;;
+ esac
;;
- esac
- case "$dflt" in
- '') dflt=`$egrep 'inlibc|csym' $rsrc/Configure | wc -l 2>/dev/null`
- if $test $dflt -gt 20; then
- dflt=y
- else
- dflt=n
- fi
+ *) dflt="$vendorlib"
;;
esac
+ fn=d~+
+ rp='Pathname for the vendor-supplied library files?'
+ . ./getfile
+ vendorlib="$ans"
+ vendorlibexp="$ansexp"
;;
-*)
- case "$usenm" in
- true|$define) dflt=y;;
- *) dflt=n;;
+esac
+vendorlib_stem=`echo "$vendorlibexp" | sed "s,/$version$,,"`
+prefixvar=vendorlib
+. ./installprefix
+
+: Set the vendorarch variables
+case "$vendorprefix" in
+'') d_vendorarch="$undef"
+ vendorarch=''
+ vendorarchexp=''
+ ;;
+*) d_vendorarch="$define"
+ : determine where vendor-supplied architecture-dependent libraries go.
+ : vendorlib default is /usr/local/lib/perl5/vendor_perl/$version
+ : vendorarch default is /usr/local/lib/perl5/vendor_perl/$version/$archname
+ : vendorlib may have an optional trailing /share.
+ case "$vendorarch" in
+ '') dflt=`echo $vendorlib | $sed 's,/share$,,'`
+ dflt="$dflt/$archname"
+ ;;
+ *) dflt="$vendorarch" ;;
esac
+ fn=d~+
+ rp='Pathname for vendor-supplied architecture-dependent files?'
+ . ./getfile
+ vendorarch="$ans"
+ vendorarchexp="$ansexp"
;;
esac
-$cat <<EOM
-
-I can use $nm to extract the symbols from your C libraries. This
-is a time consuming task which may generate huge output on the disk (up
-to 3 megabytes) but that should make the symbols extraction faster. The
-alternative is to skip the 'nm' extraction part and to compile a small
-test program instead to determine whether each symbol is present. If
-you have a fast C compiler and/or if your 'nm' output cannot be parsed,
-this may be the best solution.
+prefixvar=vendorarch
+. ./installprefix
+if $test X"$vendorarch" = X"$vendorlib"; then
+ d_vendorarch="$undef"
+else
+ d_vendorarch="$define"
+fi
-You probably shouldn't let me use 'nm' if you are using the GNU C Library.
+: Final catch-all directories to search
+$cat <<EOM
+Lastly, you can have perl look in other directories for extensions and
+modules in addition to those already specified.
+These directories will be searched after
+ $sitearch
+ $sitelib
EOM
-rp="Shall I use $nm to extract C symbols from the libraries?"
-. ./myread
-case "$ans" in
-[Nn]*) usenm=false;;
-*) usenm=true;;
+test X"$vendorlib" != "X" && echo ' ' $vendorlib
+test X"$vendorarch" != "X" && echo ' ' $vendorarch
+echo ' '
+case "$otherlibdirs" in
+''|' ') dflt='none' ;;
+*) dflt="$otherlibdirs" ;;
esac
+$cat <<EOM
+Enter a colon-separated set of extra paths to include in perl's @INC
+search path, or enter 'none' for no extra paths.
-runnm=$usenm
-case "$reuseval" in
-true) runnm=false;;
-esac
+EOM
-: nm options which may be necessary
-case "$nm_opt" in
-'') if $test -f /mach_boot; then
- nm_opt='' # Mach
- elif $test -d /usr/ccs/lib; then
- nm_opt='-p' # Solaris (and SunOS?)
- elif $test -f /dgux; then
- nm_opt='-p' # DG-UX
- elif $test -f /lib64/rld; then
- nm_opt='-p' # 64-bit Irix
- else
- nm_opt=''
- fi;;
+rp='Colon-separated list of additional directories for perl to search?'
+. ./myread
+case "$ans" in
+' '|''|none) otherlibdirs=' ' ;;
+*) otherlibdirs="$ans" ;;
esac
-
-: nm options which may be necessary for shared libraries but illegal
-: for archive libraries. Thank you, Linux.
-case "$nm_so_opt" in
-'') case "$myuname" in
- *linux*|gnu*)
- if $nm --help | $grep 'dynamic' > /dev/null 2>&1; then
- nm_so_opt='--dynamic'
- fi
- ;;
- esac
- ;;
+case "$otherlibdirs" in
+' ') val=$undef ;;
+*) val=$define ;;
esac
+set d_perl_otherlibdirs
+eval $setvar
-: Figure out where the libc is located
-case "$runnm" in
-true)
-: get list of predefined functions in a handy place
+: Cruising for prototypes
echo " "
-case "$libc" in
-'') libc=unknown
- case "$libs" in
- *-lc_s*) libc=`./loc libc_s$_a $libc $libpth`
- esac
- ;;
-esac
-case "$libs" in
-'') ;;
-*) for thislib in $libs; do
- case "$thislib" in
- -lc|-lc_s)
- : Handle C library specially below.
- ;;
- -l*)
- thislib=`echo $thislib | $sed -e 's/^-l//'`
- if try=`./loc lib$thislib.$so.'*' X $libpth`; $test -f "$try"; then
- :
- elif try=`./loc lib$thislib.$so X $libpth`; $test -f "$try"; then
- :
- elif try=`./loc lib$thislib$_a X $libpth`; $test -f "$try"; then
- :
- elif try=`./loc $thislib$_a X $libpth`; $test -f "$try"; then
- :
- elif try=`./loc lib$thislib X $libpth`; $test -f "$try"; then
- :
- elif try=`./loc $thislib X $libpth`; $test -f "$try"; then
- :
- elif try=`./loc Slib$thislib$_a X $xlibpth`; $test -f "$try"; then
- :
- else
- try=''
- fi
- libnames="$libnames $try"
- ;;
- *) libnames="$libnames $thislib" ;;
- esac
- done
- ;;
-esac
-xxx=normal
-case "$libc" in
-unknown)
- set /lib/libc.$so
- for xxx in $libpth; do
- $test -r $1 || set $xxx/libc.$so
- : The messy sed command sorts on library version numbers.
- $test -r $1 || \
- set `echo blurfl; echo $xxx/libc.$so.[0-9]* | \
- tr ' ' $trnl | egrep -v '\.[A-Za-z]*$' | $sed -e '
- h
- s/[0-9][0-9]*/0000&/g
- s/0*\([0-9][0-9][0-9][0-9][0-9]\)/\1/g
- G
- s/\n/ /' | \
- $sort | $sed -e 's/^.* //'`
- eval set \$$#
- done
- $test -r $1 || set $sysroot/usr/ccs/lib/libc.$so
- $test -r $1 || set $sysroot/lib/libsys_s$_a
- ;;
-*)
- set blurfl
- ;;
-esac
-if $test -r "$1"; then
- echo "Your (shared) C library seems to be in $1."
- libc="$1"
-elif $test -r /lib/libc && $test -r /lib/clib; then
- echo "Your C library seems to be in both /lib/clib and /lib/libc."
- xxx=apollo
- libc='/lib/clib /lib/libc'
- if $test -r /lib/syslib; then
- echo "(Your math library is in /lib/syslib.)"
- libc="$libc /lib/syslib"
- fi
-elif $test -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then
- echo "Your C library seems to be in $libc, as you said before."
-elif $test -r $incpath/usr/lib/libc$_a; then
- libc=$incpath/usr/lib/libc$_a;
- echo "Your C library seems to be in $libc. That's fine."
-elif $test -r /lib/libc$_a; then
- libc=/lib/libc$_a;
- echo "Your C library seems to be in $libc. You're normal."
+echo "Checking out function prototypes..." >&4
+$cat >prototype.c <<EOCP
+#$i_stdlib I_STDLIB
+#ifdef I_STDLIB
+#include <stdlib.h>
+#endif
+int main(int argc, char *argv[]) {
+ exit(0);}
+EOCP
+if $cc $ccflags -c prototype.c >prototype.out 2>&1 ; then
+ echo "Your C compiler appears to support function prototypes."
+ val="$define"
else
- if tans=`./loc libc$_a blurfl/dyick $libpth`; $test -r "$tans"; then
- :
- elif tans=`./loc libc blurfl/dyick $libpth`; $test -r "$tans"; then
- libnames="$libnames "`./loc clib blurfl/dyick $libpth`
- elif tans=`./loc clib blurfl/dyick $libpth`; $test -r "$tans"; then
- :
- elif tans=`./loc Slibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then
- :
- elif tans=`./loc Mlibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then
- :
- else
- tans=`./loc Llibc$_a blurfl/dyick $xlibpth`
- fi
- if $test -r "$tans"; then
- echo "Your C library seems to be in $tans, of all places."
- libc=$tans
- else
- libc='blurfl'
- fi
-fi
-if $test $xxx = apollo -o -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then
- dflt="$libc"
- cat <<EOM
+ echo "Your C compiler doesn't seem to understand function prototypes."
+ val="$undef"
+fi
+set prototype
+eval $setvar
+$rm -f prototype*
-If the guess above is wrong (which it might be if you're using a strange
-compiler, or your machine supports multiple models), you can override it here.
+: Check if ansi2knr is required
+case "$prototype" in
+"$define") ;;
+*) ansi2knr='ansi2knr'
+ echo " "
+ cat <<EOM >&4
-EOM
-else
- dflt=''
- echo $libpth | $tr ' ' $trnl | $sort | $uniq > libpath
- cat >&4 <<EOM
-I can't seem to find your C library. I've looked in the following places:
+$me: FATAL ERROR:
+This version of $package can only be compiled by a compiler that
+understands function prototypes. Unfortunately, your C compiler
+ $cc $ccflags
+doesn't seem to understand them. Sorry about that.
+
+If GNU cc is available for your system, perhaps you could try that instead.
+
+Eventually, we hope to support building Perl with pre-ANSI compilers.
+If you would like to help in that effort, please contact <perlbug@perl.org>.
+Aborting Configure now.
EOM
- $sed 's/^/ /' libpath
- cat <<EOM
+ exit 2
+ ;;
+esac
-None of these seems to contain your C library. I need to get its name...
+: DTrace support
+dflt_dtrace='/usr/sbin/dtrace'
+$test -x /usr/bin/dtrace && dflt_dtrace='/usr/bin/dtrace'
+
+cat <<EOM
+
+Perl can be built to support DTrace on platforms that support it.
+DTrace is a diagnosis and performance analysis tool from Sun.
+If this doesn't make any sense to you, just accept the default '$dflt'.
EOM
-fi
-fn=f
-rp='Where is your C library?'
-. ./getfile
-libc="$ans"
-echo " "
-echo $libc $libnames | $tr ' ' $trnl | $sort | $uniq > libnames
-set X `cat libnames`
-shift
-xxx=files
-case $# in 1) xxx=file; esac
-echo "Extracting names from the following $xxx for later perusal:" >&4
-echo " "
-$sed 's/^/ /' libnames >&4
-echo " "
-$echo $n "This may take a while...$c" >&4
+while $test 1 ; do
+ case "$usedtrace" in
+ $define|true|[yY]*)
+ dflt='y'
+ ;;
+ ?*)
+ dflt='y'
+ dflt_dtrace=$usedtrace
+ ;;
+ *)
+ dflt='n'
+ ;;
+ esac
-for file in $*; do
- case $file in
- *$so*) $nm $nm_so_opt $nm_opt $file 2>/dev/null;;
- *) $nm $nm_opt $file 2>/dev/null;;
+ rp='Support DTrace if available?'
+ . ./myread
+ case "$ans" in
+ y|Y) val="$define" ;;
+ *) val="$undef" ;;
esac
-done >libc.tmp
+ set usedtrace
+ eval $setvar
-$echo $n ".$c"
-$grep fprintf libc.tmp > libc.ptf
-xscan='eval "<libc.ptf $com >libc.list"; $echo $n ".$c" >&4'
-xrun='eval "<libc.tmp $com >libc.list"; echo "done." >&4'
-xxx='[ADTSIWi]'
-if com="$sed -n -e 's/__IO//' -e 's/^.* $xxx *//p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-elif com="$sed -n -e 's/^__*//' -e 's/^\([a-zA-Z_0-9$]*\).*xtern.*/\1/p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-elif com="$sed -n -e '/|UNDEF/d' -e '/FUNC..GL/s/^.*|__*//p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-elif com="$sed -n -e 's/^.* D __*//p' -e 's/^.* D //p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-elif com="$sed -n -e 's/^_//' -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-elif com="$grep '|' | $sed -n -e '/|COMMON/d' -e '/|DATA/d' \
- -e '/ file/d' -e 's/^\([^ ]*\).*/\1/p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p' -e 's/^.*|FUNC |WEAK .*|//p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-elif com="$sed -n -e 's/^__//' -e '/|Undef/d' -e '/|Proc/s/ .*//p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-elif com="$sed -n -e 's/^.*|Proc .*|Text *| *//p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-elif com="$sed -n -e '/Def. Text/s/.* \([^ ]*\)\$/\1/p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-elif com="$sed -n -e 's/^[-0-9a-f ]*_\(.*\)=.*/\1/p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-elif com="$sed -n -e 's/.*\.text n\ \ \ \.//p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-elif com="sed -n -e 's/^__.*//' -e 's/[ ]*D[ ]*[0-9]*.*//p'";\
- eval $xscan;\
- $contains '^fprintf$' libc.list >/dev/null 2>&1; then
- eval $xrun
-else
- $nm -p $* 2>/dev/null >libc.tmp
- $grep fprintf libc.tmp > libc.ptf
- if com="$sed -n -e 's/^.* [ADTSIW] *_[_.]*//p' -e 's/^.* [ADTSIW] //p'";\
- eval $xscan; $contains '^fprintf$' libc.list >/dev/null 2>&1
+ test "X$usedtrace" != "X$define" && break
+
+ echo " "
+ rp='Where is the dtrace executable?'
+ dflt=$dflt_dtrace
+ . ./getfile
+ val="$ans"
+ set dtrace
+ eval $setvar
+
+ if $test -f $dtrace
then
- nm_opt='-p'
- eval $xrun
- else
- echo " "
- echo "$nm didn't seem to work right. Trying $ar instead..." >&4
- com=''
- if $ar t $libc > libc.tmp && \
- $contains '^fprintf$' libc.tmp >/dev/null 2>&1
+ if $dtrace -h -s ../perldtrace.d \
+ -o perldtrace.tmp >/dev/null 2>&1 \
+ && rm -f perldtrace.tmp
then
- for thisname in $libnames $libc; do
- $ar t $thisname >>libc.tmp
- done
- $sed -e "s/\\$_o\$//" < libc.tmp > libc.list
- echo "Ok." >&4
- elif test "X$osname" = "Xos2" && $ar tv $libc > libc.tmp; then
- for thisname in $libnames $libc; do
- $ar tv $thisname >>libc.tmp
- emximp -o tmp.imp $thisname \
- 2>/dev/null && \
- $sed -e 's/^\([_a-zA-Z0-9]*\) .*$/\1/p' \
- < tmp.imp >>libc.tmp
- $rm -f tmp.imp
- done
- $sed -e "s/\\$_o\$//" -e 's/^ \+//' < libc.tmp > libc.list
- echo "Ok." >&4
+ echo " "
+ echo "Good: your $dtrace knows about the -h flag."
else
- echo "$ar didn't seem to work right." >&4
- echo "Maybe this is a Cray...trying bld instead..." >&4
- if bld t $libc | \
- $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" > libc.list &&
- $test -s libc.list
- then
- for thisname in $libnames; do
- bld t $libnames | \
- $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" >>libc.list
- $ar t $thisname >>libc.tmp
- done
- echo "Ok." >&4
- else
- echo "That didn't work either. Giving up." >&4
- exit 1
- fi
+ cat >&2 <<EOM
+
+*** $me: Fatal Error: $dtrace doesn't support -h flag
+***
+*** Your installed dtrace doesn't support the -h switch to compile a D
+*** program into a C header. Can't continue.
+
+EOM
+ exit 1
fi
+ break;
fi
-fi
-nm_extract="$com"
-case "$PASE" in
-define)
- echo " "
- echo "Since you are compiling for PASE, extracting more symbols from libc.a ...">&4
- dump -Tv /lib/libc.a | awk '$7 == "/unix" {print $5 " " $8}' | grep "^SV" | awk '{print $2}' >> libc.list
- ;;
-*) if $test -f /lib/syscalls.exp; then
- echo " "
- echo "Also extracting names from /lib/syscalls.exp for good ole AIX..." >&4
- $sed -n 's/^\([^ ]*\)[ ]*syscall[0-9]*[ ]*$/\1/p' \
- /lib/syscalls.exp >>libc.list
- fi
- ;;
+
+ case "$fastread" in
+ yes)
+ cat >&2 <<EOM
+
+*** $me: Fatal Error: $dtrace not found.
+*** Can't continue.
+
+EOM
+ exit 1
+ ;;
+ *)
+ echo "*** $dtrace was not found."
+ echo " "
+ ;;
+ esac
+done
+
+: See if we want extra modules installed
+echo " "
+case "$extras" in
+'') dflt='n';;
+*) dflt='y';;
+esac
+cat <<EOM
+Perl can be built with extra modules or bundles of modules which
+will be fetched from the CPAN and installed alongside Perl.
+
+Notice that you will need access to the CPAN; either via the Internet,
+or a local copy, for example a CD-ROM or a local CPAN mirror. (You will
+be asked later to configure the CPAN.pm module which will in turn do
+the installation of the rest of the extra modules or bundles.)
+
+Notice also that if the modules require any external software such as
+libraries and headers (the libz library and the zlib.h header for the
+Compress::Zlib module, for example) you MUST have any such software
+already installed, this configuration process will NOT install such
+things for you.
+
+If this doesn't make any sense to you, just accept the default '$dflt'.
+EOM
+rp='Install any extra modules (y or n)?'
+. ./myread
+case "$ans" in
+y|Y)
+ cat <<EOM
+
+Please list any extra modules or bundles to be installed from CPAN,
+with spaces between the names. The names can be in any format the
+'install' command of CPAN.pm will understand. (Answer 'none',
+without the quotes, to install no extra modules or bundles.)
+EOM
+ rp='Extras?'
+ dflt="$extras"
+ . ./myread
+ extras="$ans"
esac
-;;
+case "$extras" in
+''|'none')
+ val=''
+ $rm -f ../extras.lst
+ ;;
+*) echo "(Saving the list of extras for later...)"
+ echo "$extras" > ../extras.lst
+ val="'$extras'"
+ ;;
esac
-$rm -f libnames libpath
+set extras
+eval $setvar
+echo " "
+
+: determine where html pages for programs go
+set html1dir html1dir none
+eval $prefixit
+$cat <<EOM
+
+If you wish to install html files for programs in $spackage, indicate
+the appropriate directory here. To skip installing html files,
+answer "none".
+EOM
+case "$html1dir" in
+''|none|$undef|' ') dflt=none ;;
+*) dflt=$html1dir ;;
+esac
+fn=dn+~
+rp="Directory for the main $spackage html pages?"
+. ./getfile
+prefixvar=html1dir
+. ./setprefixvar
+: Use ' ' for none so value is preserved next time through Configure
+$test X"$html1dir" = "X" && html1dir=' '
+
+: determine where html pages for libraries and modules go
+set html3dir html3dir none
+eval $prefixit
+$cat <<EOM
+
+If you wish to install html files for modules associated with $spackage,
+indicate the appropriate directory here. To skip installing html files,
+answer "none".
+EOM
+: There is no obvious default. If they have specified html1dir, then
+: try to key off that, possibly changing .../html1 into .../html3.
+case "$html3dir" in
+'') html3dir=`echo "$html1dir" | $sed 's/1$/3$/'` ;;
+*) dflt=$html3dir ;;
+esac
+fn=dn+~
+rp="Directory for the $spackage module html pages?"
+. ./getfile
+prefixvar=html3dir
+. ./setprefixvar
+: Use ' ' for none so value is preserved next time through Configure
+$test X"$html3dir" = "X" && html3dir=' '
+
+: determine whether to install perl also as /usr/bin/perl
-: Check if we are using C++
echo " "
-echo "Checking for C++..." >&4
-$cat >try.c <<'EOCP'
-#include <stdio.h>
-int main(void)
-{
-#ifdef __cplusplus
- return 0;
-#else
- return 1;
-#endif
-}
-EOCP
-set try
-if eval $compile_ok && $run ./try; then
- val="$define"
- echo "You are using a C++ compiler."
+if $test -d /usr/bin -a "X$installbin" != X/usr/bin; then
+ $cat <<EOM
+Many scripts expect perl to be installed as /usr/bin/perl.
+
+If you want to, I can install the perl you are about to compile
+as /usr/bin/perl (in addition to $bin/perl).
+EOM
+ if test -f /usr/bin/perl; then
+ $cat <<EOM
+
+However, please note that because you already have a /usr/bin/perl,
+overwriting that with a new Perl would very probably cause problems.
+Therefore I'm assuming you don't want to do that (unless you insist).
+
+EOM
+ case "$installusrbinperl" in
+ "$define"|[yY]*) dflt='y';;
+ *) dflt='n';;
+ esac
+ else
+ $cat <<EOM
+
+Since you don't have a /usr/bin/perl I'm assuming creating one is okay.
+
+EOM
+ case "$installusrbinperl" in
+ "$undef"|[nN]*) dflt='n';;
+ *) dflt='y';;
+ esac
+ fi
+ rp="Do you want to install perl as /usr/bin/perl?"
+ . ./myread
+ case "$ans" in
+ [yY]*) val="$define";;
+ *) val="$undef" ;;
+ esac
else
val="$undef"
- echo "You are not using a C++ compiler."
fi
-$rm_try cplusplus$$
-set d_cplusplus
+set installusrbinperl
eval $setvar
-: is a C symbol defined?
-csym='tlook=$1;
-case "$3" in
--v) tf=libc.tmp; tdc="";;
--a) tf=libc.tmp; tdc="[]";;
-*) tlook="^$1\$"; tf=libc.list; tdc="()";;
-esac;
-case "$d_cplusplus" in
- $define) extern_C="extern \"C\"" ;;
- *) extern_C="extern" ;;
-esac;
-tx=yes;
-case "$reuseval-$4" in
-true-) ;;
-true-*) tx=no; eval "tval=\$$4"; case "$tval" in "") tx=yes;; esac;;
-esac;
-case "$tx" in
-yes)
- tval=false;
- if $test "$runnm" = true; then
- if $contains $tlook $tf >/dev/null 2>&1; then
- tval=true;
- elif $test "$mistrustnm" = compile -o "$mistrustnm" = run; then
- echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { return &$1; } int main() { if(p() && p() != (void *)main) return(0); else return(1); }"> try.c;
- $cc -o try $optimize $ccflags $ldflags try.c >/dev/null 2>&1 $libs && tval=true;
- $test "$mistrustnm" = run -a -x try && { $run ./try$_exe >/dev/null 2>&1 || tval=false; };
- $rm_try;
- fi;
- else
- echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { return &$1; } int main() { if(p() && p() != (void *)main) return(0); else return(1); }"> try.c;
- $cc -o try $optimize $ccflags $ldflags try.c $libs >/dev/null 2>&1 && tval=true;
- $rm_try;
- fi;
- ;;
-*)
- case "$tval" in
- $define) tval=true;;
- *) tval=false;;
- esac;
- ;;
-esac;
-eval "$2=$tval"'
-
-: define an is-in-libc? function
-inlibc='echo " "; td=$define; tu=$undef;
-sym=$1; var=$2; eval "was=\$$2";
-tx=yes;
-case "$reuseval$was" in
-true) ;;
-true*) tx=no;;
-esac;
-case "$tx" in
-yes)
- set $sym tres -f;
- eval $csym;
- case "$tres" in
- true)
- echo "$sym() found." >&4;
- case "$was" in $undef) . ./whoa; esac; eval "$var=\$td";;
- *)
- echo "$sym() NOT found." >&4;
- case "$was" in $define) . ./whoa; esac; eval "$var=\$tu";;
- esac;;
-*)
- case "$was" in
- $define) echo "$sym() found." >&4;;
- *) echo "$sym() NOT found." >&4;;
- esac;;
-esac'
-
: see if dlopen exists
xxx_runnm="$runnm"
xxx_ccflags="$ccflags"
esac
case "$ldflags" in
+ *-fstack-protector-strong*)
+ case "$dflt" in
+ *-fstack-protector-strong*) ;; # Don't add it again
+ *) dflt="$dflt -fstack-protector-strong" ;;
+ esac
+ ;;
*-fstack-protector*)
case "$dflt" in
*-fstack-protector*) ;; # Don't add it again
set accessx d_accessx
eval $inlibc
+: see if acosh exists
+set acosh d_acosh
+eval $inlibc
+
: see if aintl exists
set aintl d_aintl
eval $inlibc
set limits.h i_limits
eval $inhdr
-: see if this is a float.h system
-set float.h i_float
-eval $inhdr
-
: See if number of significant digits in a double precision number is known
echo " "
$cat >dbl_dig.c <<EOM
fi
$rm_try
+: see if fegetround exists
+set fegetround d_fegetround
+eval $inlibc
+
: see if fgetpos exists
set fgetpos d_fgetpos
eval $inlibc
set finitel d_finitel
eval $inlibc
-: see if flock exists
-set flock d_flock
+: see if flock exists
+set flock d_flock
+eval $inlibc
+
+: see if prototype for flock is available
+echo " "
+set d_flockproto flock $i_sysfile sys/file.h
+eval $hasproto
+
+: see if fp_class exists
+set fp_class d_fp_class
+eval $inlibc
+
+: see if this is a math.h system
+set math.h i_math
+eval $inhdr
+
+: check for fpclassify
+echo "Checking to see if you have fpclassify..." >&4
+$cat >try.c <<EOCP
+#$i_math I_MATH
+#ifdef I_MATH
+#include <math.h>
+#endif
+int main() { return fpclassify(1.0) == FP_NORMAL ? 0 : 1; }
+EOCP
+set try
+if eval $compile; then
+ val="$define"
+ echo "You have fpclassify."
+else
+ val="$undef"
+ echo "You do not have fpclassify."
+fi
+$rm_try
+set d_fpclassify
+eval $setvar
+
+: see if fp_classify exists
+set fp_classify d_fp_classify
eval $inlibc
-: see if prototype for flock is available
-echo " "
-set d_flockproto flock $i_sysfile sys/file.h
-eval $hasproto
-
-: see if fp_class exists
-set fp_class d_fp_class
+: see if fp_classl exists
+set fp_classl d_fp_classl
eval $inlibc
: see if pathconf exists
set fpclass d_fpclass
eval $inlibc
-: see if fpclassify exists
-set fpclassify d_fpclassify
-eval $inlibc
-
: see if fpclassl exists
set fpclassl d_fpclassl
eval $inlibc
+: see if fpgetround exists
+set fpgetround d_fpgetround
+eval $inlibc
+
: check for fpos64_t
echo " "
echo "Checking to see if you have fpos64_t..." >&4
eval $setvar
$rm -f isblank*
-: see if isfinite exists
-set isfinite d_isfinite
-eval $inlibc
+: check for isfinite
+echo "Checking to see if you have isfinite..." >&4
+$cat >try.c <<EOCP
+#$i_math I_MATH
+#ifdef I_MATH
+#include <math.h>
+#endif
+int main() { return isfinite(0.0); }
+EOCP
+set try
+if eval $compile; then
+ val="$define"
+ echo "You have isfinite."
+else
+ val="$undef"
+ echo "You do not have isfinite."
+fi
+$rm_try
+set d_isfinite
+eval $setvar
-: see if isinf exists
-set isinf d_isinf
+: see if isfinitel exists
+set isfinitel d_isfinitel
eval $inlibc
-: see if isnan exists
-set isnan d_isnan
+: check for isinf
+echo "Checking to see if you have isinf..." >&4
+$cat >try.c <<EOCP
+#$i_math I_MATH
+#ifdef I_MATH
+#include <math.h>
+#endif
+int main() { return isinf(0.0); }
+EOCP
+set try
+if eval $compile; then
+ val="$define"
+ echo "You have isinf."
+else
+ val="$undef"
+ echo "You do not have isinf."
+fi
+$rm_try
+set d_isinf
+eval $setvar
+
+: see if isinfl exists
+set isinfl d_isinfl
eval $inlibc
+: check for isnan
+echo "Checking to see if you have isnan..." >&4
+$cat >try.c <<EOCP
+#$i_math I_MATH
+#ifdef I_MATH
+#include <math.h>
+#endif
+int main() { return isnan(0.0); }
+EOCP
+set try
+if eval $compile; then
+ val="$define"
+ echo "You have isnan."
+else
+ val="$undef"
+ echo "You do not have isnan."
+fi
+$rm_try
+set d_isnan
+eval $setvar
+
: see if isnanl exists
set isnanl d_isnanl
eval $inlibc
+: see if j0 exists
+set j0 d_j0
+eval $inlibc
+
+: see if j0l exists
+set j0l d_j0l
+eval $inlibc
+
: see if killpg exists
set killpg d_killpg
eval $inlibc
set d_ldbl_dig
eval $setvar
-: see if ldexpl exists
-set ldexpl d_ldexpl
-eval $inlibc
-
-: see if this is a math.h system
-set math.h i_math
-eval $inhdr
-
: check to see if math.h defines _LIB_VERSION
d_libm_lib_version="$undef"
case $i_math in
esac
+: check for fpclassify
+echo " "
+echo "Checking to see if you have fpclassify..." >&4
+$cat >try.c <<EOCP
+#$i_math I_MATH
+#ifdef I_MATH
+#include <math.h>
+#endif
+int main() { return fpclassify(1.0) == FP_NORMAL ? 0 : 1; }
+EOCP
+set try
+if eval $compile; then
+ val="$define"
+ echo "You have fpclassify."
+else
+ val="$undef"
+ echo "You do not have fpclassify."
+fi
+$rm_try
+set d_fpclassify
+eval $setvar
+
+: check for isfinite
+echo " "
+echo "Checking to see if you have isfinite..." >&4
+$cat >try.c <<EOCP
+#$i_math I_MATH
+#ifdef I_MATH
+#include <math.h>
+#endif
+int main() { return isfinite(0.0); }
+EOCP
+set try
+if eval $compile; then
+ val="$define"
+ echo "You have isfinite."
+else
+ val="$undef"
+ echo "You do not have isfinite."
+fi
+$rm_try
+set d_isfinite
+eval $setvar
+
+: check for isinf
+echo " "
+echo "Checking to see if you have isinf..." >&4
+$cat >try.c <<EOCP
+#$i_math I_MATH
+#ifdef I_MATH
+#include <math.h>
+#endif
+int main() { return isinf(0.0); }
+EOCP
+set try
+if eval $compile; then
+ val="$define"
+ echo "You have isinf."
+else
+ val="$undef"
+ echo "You do not have isinf."
+fi
+$rm_try
+set d_isinf
+eval $setvar
+
+: check for isnan
+echo " "
+echo "Checking to see if you have isnan..." >&4
+$cat >try.c <<EOCP
+#$i_math I_MATH
+#ifdef I_MATH
+#include <math.h>
+#endif
+int main() { return isnan(0.0); }
+EOCP
+set try
+if eval $compile; then
+ val="$define"
+ echo "You have isnan."
+else
+ val="$undef"
+ echo "You do not have isnan."
+fi
+$rm_try
+set d_isnan
+eval $setvar
+
+: see if this is a quadmath.h system
+set quadmath.h i_quadmath
+eval $inhdr
+
: see if link exists
set link d_link
eval $inlibc
set scalbnl d_scalbnl
eval $inlibc
+: see if truncl exists
+set truncl d_truncl
+eval $inlibc
+
: see if modfl exists
set modfl d_modfl
eval $inlibc
message="$message sqrtl"
fi
if $test "$d_modfl" != "$define"; then
- if $test "$d_aintl:$d_copysignl" = "$define:$define"; then
- echo "You have both aintl and copysignl, so I can emulate modfl."
+ if $test "$d_truncl:$d_copysignl" = "$define:$define"; then
+ echo "You have both truncl and copysignl, so I can emulate modfl."
else
- message="$message modfl"
+ if $test "$d_aintl:$d_copysignl" = "$define:$define"; then
+ echo "You have both aintl and copysignl, so I can emulate modfl."
+ else
+ message="$message modfl"
+ fi
fi
fi
if $test "$d_frexpl" != "$define"; then
;;
esac
+case "$usequadmath:$i_quadmath" in
+define:define)
+ nvtype="__float128"
+ nvsize=16
+ case "$libs" in
+ *quadmath*) ;;
+ *) $cat <<EOM >&4
+
+*** You requested the use of the quadmath library, but you
+*** do not seem to have the quadmath library installed.
+*** Cannot continue, aborting.
+EOM
+ exit 1
+ ;;
+ esac
+ ;;
+define:*) $cat <<EOM >&4
+
+*** You requested the use of the quadmath library, but you
+*** do not seem to have the required header, <quadmath.h>.
+EOM
+ case "$gccversion" in
+ [23].*|4.[0-5]*)
+ $cat <<EOM >&4
+*** Your gcc looks a bit old:
+*** $gccversion
+EOM
+ ;;
+ '')
+ $cat <<EOM >&4
+*** You are not running a gcc.
+EOM
+ ;;
+ esac
+ $cat <<EOM >&4
+*** For the quadmath library you need at least gcc 4.6.
+*** Cannot continue, aborting.
+EOM
+ exit 1
+ ;;
+esac
+
$echo "(IV will be "$ivtype", $ivsize bytes)"
$echo "(UV will be "$uvtype", $uvsize bytes)"
$echo "(NV will be "$nvtype", $nvsize bytes)"
-$echo "Checking the kind of long doubles you have..." >&4
-: volatile so that the compiler has to store it out to memory.
-if test X"$d_volatile" = X"$define"; then
- volatile=volatile
-fi
-case "$d_longdbl" in
-define)
-$cat <<EOP >try.c
-#$i_float I_FLOAT
-#$i_stdlib I_STDLIB
-#define LONGDBLSIZE $longdblsize
-#ifdef I_FLOAT
-#include <float.h>
-#endif
-#ifdef I_STDLIB
-#include <stdlib.h>
-#endif
-#include <stdio.h>
-static const long double d = -0.1L;
-int main() {
- unsigned const char* b = (unsigned const char*)(&d);
-#if LDBL_MANT_DIG == 113 && LONGDBLSIZE == 16
- if (b[0] == 0x9A && b[1] == 0x99 && b[15] == 0xBF) {
- /* IEEE 754 128-bit little-endian */
- printf("1\n");
- exit(0);
- }
- if (b[0] == 0xBF && b[14] == 0x99 && b[15] == 0x9A) {
- /* IEEE 128-bit big-endian, e.g. solaris sparc */
- printf("2\n");
- exit(0);
- }
-#endif
-#if LDBL_MANT_DIG == 64 && (LONGDBLSIZE == 16 || LONGDBLSIZE == 12)
- if (b[0] == 0xCD && b[9] == 0xBF && b[10] == 0x00) {
- /* x86 80-bit little-endian, sizeof 12 (ILP32, Solaris x86)
- * or 16 (LP64, Linux and OS X), 4 or 6 bytes of padding.
- * Also known as "extended precision". */
- printf("3\n");
- exit(0);
- }
- if (b[LONGDBLSIZE - 11] == 0x00 && b[LONGDBLSIZE - 10] == 0xBF &&
- b[LONGDBLSIZE - 1] == 0xCD) {
- /* is there ever big-endian 80-bit, really? */
- printf("4\n");
- exit(0);
- }
-#endif
-#if LDBL_MANT_DIG == 106 && LONGDBLSIZE == 16
- /* software "double double", the 106 is 53+53 */
- if (b[0] == 0x9A && b[7] == 0x3C && b[8] == 0x9A && b[15] == 0xBF) {
- /* double double 128-bit little-endian,
- * 9a 99 99 99 99 99 59 3c 9a 99 99 99 99 99 b9 bf */
- printf("5\n");
- exit(0);
- }
- if (b[0] == 0xBF && b[7] == 0x9A && b[8] == 0x3C && b[15] == 0x9A) {
- /* double double 128-bit big-endian, e.g. PPC/Power and MIPS:
- * bf b9 99 99 99 99 99 9a 3c 59 99 99 99 99 99 9a */
- printf("6\n");
- exit(0);
- }
-#endif
- printf("-1\n"); /* unknown */
- exit(0);
-}
-EOP
-set try
-if eval $compile; then
- longdblkind=`$run ./try`
-else
- longdblkind=-1
-fi
-;;
-*) longdblkind=0 ;;
-esac
-case "$longdblkind" in
-0) echo "Your long doubles are doubles." >&4 ;;
-1) echo "You have IEEE 754 128-bit little endian long doubles." >&4 ;;
-2) echo "You have IEEE 754 128-bit big endian long doubles." >&4 ;;
-3) echo "You have x86 80-bit little endian long doubles." >& 4 ;;
-*) echo "Cannot figure out your long double." >&4 ;;
-esac
-$rm_try
-
$cat >try.c <<EOCP
#$i_inttypes I_INTTYPES
#ifdef I_INTTYPES
case $d_prctl in
$define)
$cat >try.c <<EOM
+#ifdef __ANDROID__
+#include <unistd.h>
+#endif
#include <sys/prctl.h>
int main (int argc, char *argv[])
fi
fi
-if $test X"$uselongdouble" = X"$define" -a X"$d_longdbl" = X"$define" -a X"$d_PRIgldbl" = X"$define"; then
+if $test X"$usequadmath" = X"$define"; then
+ nveformat='"Qe"'
+ nvfformat='"Qf"'
+ nvgformat='"Qg"'
+ nvEUformat='"QE"'
+ nvFUformat='"QF"'
+ nvGUformat='"QG"'
+else
+ if $test X"$uselongdouble" = X"$define" -a X"$d_longdbl" = X"$define" -a X"$d_PRIgldbl" = X"$define"; then
nveformat="$sPRIeldbl"
nvfformat="$sPRIfldbl"
nvgformat="$sPRIgldbl"
nvEUformat="$sPRIEUldbl"
nvFUformat="$sPRIFUldbl"
nvGUformat="$sPRIGUldbl"
-else
+ else
nveformat='"e"'
nvfformat='"f"'
nvgformat='"g"'
nvEUformat='"E"'
nvFUformat='"F"'
nvGUformat='"G"'
+ fi
fi
case "$ivdformat" in
set size_t sizetype 'unsigned int' stdio.h sys/types.h
eval $typedef_ask
-: check for type of arguments to gethostbyaddr.
+: check for type of arguments to gethostbyaddr.
if test "X$netdb_host_type" = X -o "X$netdb_hlen_type" = X; then
case "$d_gethbyaddr" in
$define)
Checking to see what type of arguments are accepted by gethostbyaddr().
EOM
hdrs="$define sys/types.h
- $d_socket sys/socket.h
- $i_niin netinet/in.h
+ $d_socket sys/socket.h
+ $i_niin netinet/in.h
$i_netdb netdb.h
$i_unistd unistd.h"
: The first arg can 'char *' or 'void *'
netdb_hlen_type="$sizetype"
;;
esac
- # Remove the "const" if needed. -- but then we'll have a
+ # Remove the "const" if needed. -- but then we'll have a
# prototype clash!
# netdb_host_type=`echo "$netdb_host_type" | sed 's/^const //'`
fi
-: check for type of argument to gethostbyname.
+: check for type of argument to gethostbyname.
if test "X$netdb_name_type" = X ; then
case "$d_gethbyname" in
$define)
Checking to see what type of argument is accepted by gethostbyname().
EOM
hdrs="$define sys/types.h
- $d_socket sys/socket.h
- $i_niin netinet/in.h
+ $d_socket sys/socket.h
+ $i_niin netinet/in.h
$i_netdb netdb.h
$i_unistd unistd.h"
for xxx in "const char *" "char *"; do
esac
fi
-: check for type of 1st argument to getnetbyaddr.
+: check for type of 1st argument to getnetbyaddr.
if test "X$netdb_net_type" = X ; then
case "$d_getnbyaddr" in
$define)
Checking to see what type of 1st argument is accepted by getnetbyaddr().
EOM
hdrs="$define sys/types.h
- $d_socket sys/socket.h
- $i_niin netinet/in.h
+ $d_socket sys/socket.h
+ $i_niin netinet/in.h
$i_netdb netdb.h
$i_unistd unistd.h"
for xxx in in_addr_t "unsigned long" long "unsigned int" int; do
set execinfo.h i_execinfo
eval $inhdr
+: see if this is a fenv.h system
+set fenv.h i_fenv
+eval $inhdr
+
: see if this is a fp.h system
set fp.h i_fp
eval $inhdr
set stddef.h i_stddef
eval $inhdr
+: see if stdint is available
+set stdint.h i_stdint
+eval $inhdr
+
: see if sys/access.h is available
set sys/access.h i_sysaccess
eval $inhdr
d__fwalk='$d__fwalk'
d_access='$d_access'
d_accessx='$d_accessx'
+d_acosh='$d_acosh'
d_aintl='$d_aintl'
d_alarm='$d_alarm'
d_archlib='$d_archlib'
d_fd_macros='$d_fd_macros'
d_fd_set='$d_fd_set'
d_fds_bits='$d_fds_bits'
+d_fegetround='$d_fegetround'
d_fgetpos='$d_fgetpos'
d_finite='$d_finite'
d_finitel='$d_finitel'
d_flockproto='$d_flockproto'
d_fork='$d_fork'
d_fp_class='$d_fp_class'
+d_fp_classify='$d_fp_classify'
+d_fp_classl='$d_fp_classl'
d_fpathconf='$d_fpathconf'
d_fpclass='$d_fpclass'
d_fpclassify='$d_fpclassify'
d_fpclassl='$d_fpclassl'
+d_fpgetround='$d_fpgetround'
d_fpos64_t='$d_fpos64_t'
d_frexpl='$d_frexpl'
d_fs_data_s='$d_fs_data_s'
d_isascii='$d_isascii'
d_isblank='$d_isblank'
d_isfinite='$d_isfinite'
+d_isfinitel='$d_isfinitel'
d_isinf='$d_isinf'
+d_isinfl='$d_isinfl'
d_isnan='$d_isnan'
d_isnanl='$d_isnanl'
+d_j0='$d_j0'
+d_j0l='$d_j0l'
d_killpg='$d_killpg'
d_lchown='$d_lchown'
d_ldbl_dig='$d_ldbl_dig'
d_tm_tm_zone='$d_tm_tm_zone'
d_tmpnam_r='$d_tmpnam_r'
d_truncate='$d_truncate'
+d_truncl='$d_truncl'
d_ttyname_r='$d_ttyname_r'
d_tzname='$d_tzname'
d_u32align='$d_u32align'
i_dlfcn='$i_dlfcn'
i_execinfo='$i_execinfo'
i_fcntl='$i_fcntl'
+i_fenv='$i_fenv'
i_float='$i_float'
i_fp='$i_fp'
i_fp_class='$i_fp_class'
i_prot='$i_prot'
i_pthread='$i_pthread'
i_pwd='$i_pwd'
+i_quadmath='$i_quadmath'
i_rpcsvcdbm='$i_rpcsvcdbm'
i_sgtty='$i_sgtty'
i_shadow='$i_shadow'
i_stdarg='$i_stdarg'
i_stdbool='$i_stdbool'
i_stddef='$i_stddef'
+i_stdint='$i_stdint'
i_stdlib='$i_stdlib'
i_string='$i_string'
i_sunmath='$i_sunmath'
useopcode='$useopcode'
useperlio='$useperlio'
useposix='$useposix'
+usequadmath='$usequadmath'
usereentrant='$usereentrant'
userelocatableinc='$userelocatableinc'
useshrplib='$useshrplib'
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='3'
+api_subversion='4'
api_version='21'
-api_versionstring='5.21.3'
+api_versionstring='5.21.4'
ar='ar'
-archlib='/usr/lib/perl5/5.21.3/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.21.3/armv4l-linux'
+archlib='/usr/lib/perl5/5.21.4/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.21.4/armv4l-linux'
archname64=''
archname='armv4l-linux'
archobjs=''
cat='cat'
cc='cc'
cccdlflags='-fpic'
-ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.21.3/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.21.4/armv4l-linux/CORE'
ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
ccname='arm-linux-gcc'
d__fwalk='undef'
d_access='define'
d_accessx='undef'
+d_acosh='define'
d_aintl='undef'
d_alarm='define'
d_archlib='define'
d_fd_macros='define'
d_fd_set='define'
d_fds_bits='undef'
+d_fegetround='define'
d_fgetpos='define'
d_finite='define'
d_finitel='define'
d_flockproto='define'
d_fork='define'
d_fp_class='undef'
+d_fp_classify='undef'
+d_fp_classl='undef'
d_fpathconf='define'
d_fpclass='undef'
d_fpclassify='undef'
d_fpclassl='undef'
+d_fpgetround='undef'
d_fpos64_t='undef'
d_frexpl='define'
d_fs_data_s='undef'
d_isascii='define'
d_isblank='undef'
d_isfinite='undef'
+d_isfinitel='undef'
d_isinf='define'
+d_isinfl='define'
d_isnan='define'
d_isnanl='define'
+d_j0='define'
+d_j0l='define'
d_killpg='define'
d_lchown='define'
d_ldbl_dig='define'
d_tm_tm_zone='define'
d_tmpnam_r='undef'
d_truncate='define'
+d_truncl='define'
d_ttyname_r='undef'
d_tzname='define'
d_u32align='undef'
i_dlfcn='define'
i_execinfo='undef'
i_fcntl='undef'
+i_fenv='define'
i_float='define'
i_fp='undef'
i_fp_class='undef'
i_prot='undef'
i_pthread='define'
i_pwd='define'
+i_quadmath='undef'
i_rpcsvcdbm='undef'
i_sgtty='undef'
i_shadow='define'
i_stdarg='define'
i_stdbool='undef'
i_stddef='define'
+i_stdint='define'
i_stdlib='define'
i_string='define'
i_sunmath='undef'
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='./install_me_here/usr/lib/perl5/5.21.3/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.21.4/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.3'
+installprivlib='./install_me_here/usr/lib/perl5/5.21.4'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.3/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.4/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.3'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.4'
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.3'
-privlibexp='/usr/lib/perl5/5.21.3'
+privlib='/usr/lib/perl5/5.21.4'
+privlibexp='/usr/lib/perl5/5.21.4'
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.3/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.21.3/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.21.4/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.21.4/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.21.3'
+sitelib='/usr/lib/perl5/site_perl/5.21.4'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.21.3'
+sitelibexp='/usr/lib/perl5/site_perl/5.21.4'
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='3'
+subversion='4'
sysman='/usr/share/man/man1'
tail=''
tar=''
useopcode='true'
useperlio='define'
useposix='true'
+usequadmath='undef'
usereentrant='undef'
userelocatableinc='undef'
useshrplib='true'
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.21.3'
-version_patchlevel_string='version 21 subversion 3'
+version='5.21.4'
+version_patchlevel_string='version 21 subversion 4'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_argc=0
PERL_REVISION=5
PERL_VERSION=21
-PERL_SUBVERSION=3
+PERL_SUBVERSION=4
PERL_API_REVISION=5
PERL_API_VERSION=21
-PERL_API_SUBVERSION=3
+PERL_API_SUBVERSION=4
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='3'
+api_subversion='4'
api_version='21'
-api_versionstring='5.21.3'
+api_versionstring='5.21.4'
ar='ar'
-archlib='/usr/lib/perl5/5.21.3/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.21.3/armv4l-linux'
+archlib='/usr/lib/perl5/5.21.4/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.21.4/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.3/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.21.4/armv4l-linux/CORE'
ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
ccname='arm-linux-gcc'
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='./install_me_here/usr/lib/perl5/5.21.3/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.21.4/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.3'
+installprivlib='./install_me_here/usr/lib/perl5/5.21.4'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.3/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.4/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.3'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.4'
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.3'
-privlibexp='/usr/lib/perl5/5.21.3'
+privlib='/usr/lib/perl5/5.21.4'
+privlibexp='/usr/lib/perl5/5.21.4'
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.3/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.21.3/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.21.4/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.21.4/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.21.3'
+sitelib='/usr/lib/perl5/site_perl/5.21.4'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.21.3'
+sitelibexp='/usr/lib/perl5/site_perl/5.21.4'
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='3'
+subversion='4'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.21.3'
-version_patchlevel_string='version 21 subversion 3'
+version='5.21.4'
+version_patchlevel_string='version 21 subversion 4'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_argc=0
PERL_REVISION=5
PERL_VERSION=21
-PERL_SUBVERSION=3
+PERL_SUBVERSION=4
PERL_API_REVISION=5
PERL_API_VERSION=21
-PERL_API_SUBVERSION=3
+PERL_API_SUBVERSION=4
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
(that is, Perl's numbers). Use Configure -Duselongdouble to enable
this support (if it is available).
+Note that the exact format and range of long doubles varies:
+the most common is the x86 80-bit (64 bits of mantissa) format,
+but there are others, with different mantissa and exponent ranges.
+In fact, the type may not be called "long double" at C level, and
+therefore the C<uselongdouble> means "using floating point larger
+than double".
+
=head3 "more bits"
You can "Configure -Dusemorebits" to turn on both the 64-bit support
and the long double support.
+=head3 quadmath
+
+One option for long doubles is that gcc 4.6 and later have a library
+called quadmath, which implements the IEEE 754 quadruple precision
+(128-bit, 113 bits of mantissa) floating point numbers. The library
+works at least on x86 and ia64 platforms. It may be part of your gcc
+installation, or you may need to install it separately.
+
+With "Configure -Dusequadmath" you can try enabling its use, but note
+the compiler dependency, you may need to also add "-Dcc=...".
+This option also turns on -Duselongdouble. At C level the type is called
+C<__float128> (note, not "long double"), but Perl source knows it as NV.
+
=head3 Algorithmic Complexity Attacks on Hashes
Perl 5.18 reworked the measures used to secure its hash function
=item Directories for the perl distribution
-By default, Configure will use the following directories for 5.21.3.
+By default, Configure will use the following directories for 5.21.4.
$version is the full perl version number, including subversion, e.g.
5.12.3, and $archname is a string like sun4-sunos,
determined by Configure. The full definitions of all Configure
=head1 Coexistence with earlier versions of perl 5
-Perl 5.21.3 is not binary compatible with earlier versions of Perl.
+Perl 5.21.4 is not binary compatible with earlier versions of Perl.
In other words, you will have to recompile your XS modules.
In general, you can usually safely upgrade from one version of Perl (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.3
+ sh Configure -Dprefix=/opt/perl5.21.4
-and adding /opt/perl5.21.3/bin to the shell PATH variable. Such users
+and adding /opt/perl5.21.4/bin to the shell PATH variable. Such users
may also wish to add a symbolic link /usr/local/bin/perl so that
scripts can still start with #!/usr/local/bin/perl.
subversions may not have all the compatibility wrinkles ironed out
yet.
-=head2 Upgrading from 5.21.1 or earlier
+=head2 Upgrading from 5.21.3 or earlier
-B<Perl 5.21.3 may not be binary compatible with Perl 5.21.1 or
+B<Perl 5.21.4 may not be binary compatible with Perl 5.21.3 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.3. If you find you do need to rebuild an extension with
-5.21.3, you may safely do so without disturbing the older
+used with 5.21.4. If you find you do need to rebuild an extension with
+5.21.4, 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.3 is as follows (under $Config{prefix}):
+in Linux with perl-5.21.4 is as follows (under $Config{prefix}):
./bin/perl
- ./lib/perl5/5.21.3/strict.pm
- ./lib/perl5/5.21.3/warnings.pm
- ./lib/perl5/5.21.3/i686-linux/File/Glob.pm
- ./lib/perl5/5.21.3/feature.pm
- ./lib/perl5/5.21.3/XSLoader.pm
- ./lib/perl5/5.21.3/i686-linux/auto/File/Glob/Glob.so
+ ./lib/perl5/5.21.4/strict.pm
+ ./lib/perl5/5.21.4/warnings.pm
+ ./lib/perl5/5.21.4/i686-linux/File/Glob.pm
+ ./lib/perl5/5.21.4/feature.pm
+ ./lib/perl5/5.21.4/XSLoader.pm
+ ./lib/perl5/5.21.4/i686-linux/auto/File/Glob/Glob.so
Secondly, for perl-5.10.1, the Debian perl-base package contains 591 files,
(of which 510 are for lib/unicore) totaling about 3.5MB in its i386 version.
cpan/Digest-SHA/Makefile.PL Digest::SHA Makefile.PL
cpan/Digest-SHA/shasum shasum script
cpan/Digest-SHA/SHA.xs Digest::SHA extension
+cpan/Digest-SHA/src/sdf.c Digest::SHA extension
cpan/Digest-SHA/src/sha64bit.c Digest::SHA extension
cpan/Digest-SHA/src/sha64bit.h Digest::SHA extension
cpan/Digest-SHA/src/sha.c Digest::SHA extension
cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Utils.pm generate XS code to import C header constants
cpan/ExtUtils-Constant/lib/ExtUtils/Constant/XS.pm generate XS code to import C header constants
cpan/ExtUtils-Constant/t/Constant.t See if ExtUtils::Constant works
-cpan/ExtUtils-Install/Changes ExtUtils-Install change log
cpan/ExtUtils-Install/lib/ExtUtils/Installed.pm Information on installed extensions
cpan/ExtUtils-Install/lib/ExtUtils/Install.pm Handles 'make install' on extensions
cpan/ExtUtils-Install/lib/ExtUtils/Packlist.pm Manipulates .packlist files
cpan/IO-Socket-IP/t/19no-addrs.t IO::Socket::IP tests
cpan/IO-Socket-IP/t/20subclass.t IO::Socket::IP tests
cpan/IO-Socket-IP/t/21as-inet.t IO::Socket::IP tests
+cpan/IO-Socket-IP/t/22timeout.t
cpan/IO-Socket-IP/t/30nonblocking-connect.t IO::Socket::IP tests
cpan/IO-Socket-IP/t/31nonblocking-connect-internet.t IO::Socket::IP tests
cpan/IO-Socket-IP/t/99pod.t IO::Socket::IP tests
cpan/Scalar-List-Utils/lib/List/Util.pm List::Util
cpan/Scalar-List-Utils/lib/List/Util/XS.pm List::Util
cpan/Scalar-List-Utils/lib/Scalar/Util.pm Scalar::Util
+cpan/Scalar-List-Utils/lib/Sub/Util.pm
cpan/Scalar-List-Utils/ListUtil.xs Util extension
cpan/Scalar-List-Utils/Makefile.PL Util extension
cpan/Scalar-List-Utils/multicall.h Util extension
cpan/Scalar-List-Utils/t/openhan.t Scalar::Util
cpan/Scalar-List-Utils/t/pair.t
cpan/Scalar-List-Utils/t/product.t List::Util
-cpan/Scalar-List-Utils/t/proto.t Scalar::Util
+cpan/Scalar-List-Utils/t/prototype.t
cpan/Scalar-List-Utils/t/readonly.t Scalar::Util
cpan/Scalar-List-Utils/t/reduce.t List::Util
cpan/Scalar-List-Utils/t/refaddr.t Scalar::Util
cpan/Scalar-List-Utils/t/reftype.t Scalar::Util
+cpan/Scalar-List-Utils/t/scalarutil-proto.t
cpan/Scalar-List-Utils/t/shuffle.t List::Util
cpan/Scalar-List-Utils/t/stack-corruption.t List::Util
+cpan/Scalar-List-Utils/t/subname.t
cpan/Scalar-List-Utils/t/sum0.t
cpan/Scalar-List-Utils/t/sum.t List::Util
cpan/Scalar-List-Utils/t/tainted.t Scalar::Util
dist/Data-Dumper/t/purity_deepcopy_maxdepth.t See if three Data::Dumper functions work
dist/Data-Dumper/t/qr.t See if Data::Dumper works with qr|/|
dist/Data-Dumper/t/quotekeys.t See if Data::Dumper::Quotekeys works
+dist/Data-Dumper/t/recurse.t See if Data::Dumper::Maxrecurse works
dist/Data-Dumper/t/seen.t See if Data::Dumper::Seen works
dist/Data-Dumper/t/sortkeys.t See if Data::Dumper::Sortkeys works
dist/Data-Dumper/t/sparseseen.t See if Data::Dumper::Sparseseen works
dist/Module-CoreList/MANIFEST Module::CoreList
dist/Module-CoreList/README Module::CoreList
dist/Module-CoreList/t/corelist.t Module::CoreList tests
-dist/Module-CoreList/t/corevers.t Module::CoreList tests
dist/Module-CoreList/t/deprecated.t Module::CoreList tests
dist/Module-CoreList/t/find_modules.t Module::CoreList tests
dist/Module-CoreList/t/is_core.t Module::CoreList tests
ext/XS-APItest/t/copstash.t test alloccopstash
ext/XS-APItest/t/copyhints.t test hv_copy_hints_hv() API
ext/XS-APItest/t/customop.t XS::APItest: tests for custom ops
+ext/XS-APItest/t/cv_name.t test cv_name
ext/XS-APItest/t/eval-filter.t Simple source filter/eval test
ext/XS-APItest/t/exception.t XS::APItest extension
ext/XS-APItest/t/fetch_pad_names.t Tests for UTF8 names in pad
lib/Benchmark.t See if Benchmark works
lib/blib.pm For "use blib"
lib/blib.t blib.pm test
+lib/B/Op_private.pm Definitions of OP op_private flags
lib/bytes_heavy.pl Support routines for byte pragma
lib/bytes.pm Pragma to enable byte operations
lib/bytes.t bytes.pm test
pod/perl5181delta.pod Perl changes in version 5.18.1
pod/perl5182delta.pod Perl changes in version 5.18.2
pod/perl5200delta.pod Perl changes in version 5.20.0
+pod/perl5201delta.pod Perl changes in version 5.20.1
pod/perl5210delta.pod Perl changes in version 5.21.0
pod/perl5211delta.pod Perl changes in version 5.21.1
pod/perl5212delta.pod Perl changes in version 5.21.2
+pod/perl5213delta.pod Perl changes in version 5.21.3
pod/perl561delta.pod Perl changes in version 5.6.1
pod/perl56delta.pod Perl changes in version 5.6
pod/perl581delta.pod Perl changes in version 5.8.1
regen/mk_PL_charclass.pl Populate the PL_charclass table
regen/opcode.pl Opcode header generator
regen/opcodes Opcode data
+regen/op_private Definitions of bits in an OP's op_private field
regen/overload.pl generate overload.h
regen_perly.pl generate perly.{act,h,tab} from perly.y
regen.pl Run all scripts that (re)generate files
t/op/inc.t See if inc/dec of integers near 32 bit limit work
t/op/index.t See if index works
t/op/index_thr.t See if index works in another thread
+t/op/infnan.t See if inf/nan work
t/op/int.t See if int works
t/op/join.t See if join works
t/op/kill0_child Process tree script that is kill()ed
t/re/reg_pmod.t See if regexp /p modifier works as expected
t/re/reg_posixcc.t See if posix character classes behave consistently
t/re/re_tests Regular expressions for regexp.t
+t/re/rt122747.t Test rt122747 assert faile (requires DEBUGGING)
t/re/rxcode.t See if /(?{ code })/ works
t/re/subst_amp.t See if $&-related substitution works
t/re/subst.t See if substitution works
"url" : "http://perl5.git.perl.org/"
}
},
- "version" : "5.021003"
+ "version" : "5.021004"
}
homepage: http://www.perl.org/
license: http://dev.perl.org/licenses/
repository: http://perl5.git.perl.org/
-version: '5.021003'
+version: '5.021004'
ndt_obj = $(obj0) $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
obj = $(ndt_obj) $(DTRACE_O)
-perltoc_pod_prereqs = extra.pods pod/perl5213delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod
+perltoc_pod_prereqs = extra.pods pod/perl5214delta.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
@echo `$(CCCMD)` $(PLDLFLAGS) $*.c
@`$(CCCMD)` $(PLDLFLAGS) $*.c
-.c.i:
+.c.i: perl.h config.h
@echo `$(CCCMDSRC)` -E $*.c \> $*.i
@`$(CCCMDSRC)` -E $*.c > $*.i
-.c.s:
+.c.s: perl.h config.h
@echo `$(CCCMDSRC)` -S $*.c
@`$(CCCMDSRC)` -S $*.c
pod/perlmodlib.pod: $(MINIPERL_EXE) pod/perlmodlib.PL MANIFEST
$(MINIPERL) pod/perlmodlib.PL -q
-pod/perl5213delta.pod: pod/perldelta.pod
- $(RMS) pod/perl5213delta.pod
- $(LNS) perldelta.pod pod/perl5213delta.pod
+pod/perl5214delta.pod: pod/perldelta.pod
+ $(RMS) pod/perl5214delta.pod
+ $(LNS) perldelta.pod pod/perl5214delta.pod
extra.pods: $(MINIPERL_EXE)
-@test ! -f extra.pods || rm -f `cat extra.pods`
-rmdir lib/TAP/Parser/Scheduler lib/TAP/Parser/Result
-rmdir lib/TAP/Parser/Iterator lib/TAP/Parser lib/TAP/Harness
-rmdir lib/TAP/Formatter/File lib/TAP/Formatter/Console
- -rmdir lib/TAP/Formatter lib/TAP lib/Sys/Syslog lib/Sys lib/Search
- -rmdir lib/Scalar lib/Pod/Text lib/Pod/Simple lib/Pod/Perldoc
- -rmdir lib/PerlIO/via lib/PerlIO lib/Perl lib/Parse/CPAN lib/Parse
- -rmdir lib/Params lib/Net/FTP lib/Module/Load lib/Module/CoreList
- -rmdir lib/Module lib/Memoize lib/Math/BigInt lib/Math/BigFloat
- -rmdir lib/Math lib/MIME lib/Locale/Maketext lib/Locale/Codes
- -rmdir lib/Locale lib/List/Util lib/List lib/JSON/PP lib/JSON lib/IPC
- -rmdir lib/IO/Uncompress/Adapter lib/IO/Uncompress lib/IO/Socket
- -rmdir lib/IO/Compress/Zlib lib/IO/Compress/Zip lib/IO/Compress/Gzip
- -rmdir lib/IO/Compress/Base lib/IO/Compress/Adapter lib/IO/Compress
- -rmdir lib/IO lib/I18N/LangTags lib/I18N lib/Hash/Util lib/Hash
- -rmdir lib/HTTP lib/Filter/Util lib/Filter lib/File/Spec
- -rmdir lib/ExtUtils/Typemaps lib/ExtUtils/ParseXS
- -rmdir lib/ExtUtils/MakeMaker lib/ExtUtils/Liblist
- -rmdir lib/ExtUtils/Constant lib/ExtUtils/Command
+ -rmdir lib/TAP/Formatter lib/TAP lib/Sys/Syslog lib/Sys lib/Sub
+ -rmdir lib/Search lib/Scalar lib/Pod/Text lib/Pod/Simple
+ -rmdir lib/Pod/Perldoc lib/PerlIO/via lib/PerlIO lib/Perl
+ -rmdir lib/Parse/CPAN lib/Parse lib/Params lib/Net/FTP lib/Module/Load
+ -rmdir lib/Module/CoreList lib/Module lib/Memoize lib/Math/BigInt
+ -rmdir lib/Math/BigFloat lib/Math lib/MIME lib/Locale/Maketext
+ -rmdir lib/Locale/Codes lib/Locale lib/List/Util lib/List lib/JSON/PP
+ -rmdir lib/JSON lib/IPC lib/IO/Uncompress/Adapter lib/IO/Uncompress
+ -rmdir lib/IO/Socket lib/IO/Compress/Zlib lib/IO/Compress/Zip
+ -rmdir lib/IO/Compress/Gzip lib/IO/Compress/Base
+ -rmdir lib/IO/Compress/Adapter lib/IO/Compress lib/IO
+ -rmdir lib/I18N/LangTags lib/I18N lib/Hash/Util lib/Hash lib/HTTP
+ -rmdir lib/Filter/Util lib/Filter lib/File/Spec lib/ExtUtils/Typemaps
+ -rmdir lib/ExtUtils/ParseXS lib/ExtUtils/MakeMaker
+ -rmdir lib/ExtUtils/Liblist lib/ExtUtils/Constant lib/ExtUtils/Command
-rmdir lib/ExtUtils/CBuilder/Platform/Windows
-rmdir lib/ExtUtils/CBuilder/Platform lib/ExtUtils/CBuilder
-rmdir lib/Exporter lib/Encode/Unicode lib/Encode/MIME/Header
$spitshell >>$Makefile <<'!NO!SUBS!'
.PHONY: depend
-depend: makedepend $(DTRACE_H)
+depend: makedepend $(DTRACE_H) $(generated_headers)
sh ./makedepend MAKE="$(MAKE)" cflags
.PHONY: test check test_prep test_prep_nodll test_prep_pre \
# Here comes the CW tools - TO BE FILLED TO BUILD WITH CW -
-MODULE_DESC = "Perl 5.21.3 for NetWare"
+MODULE_DESC = "Perl 5.21.4 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.3
+INST_VER = \5.21.4
#
# Comment this out if you DON'T want your perl installation to have
d__fwalk='undef'
d_access='define'
d_accessx='undef'
+d_acosh='undef'
d_aintl='undef'
d_alarm='undef'
d_archlib='define'
d_fd_macros='define'
d_fd_set='define'
d_fds_bits='define'
+d_fegetround='undef'
d_fgetpos='define'
d_finite='undef'
d_finitel='undef'
d_flockproto='undef'
d_fork='undef'
d_fp_class='undef'
+d_fp_classify='undef'
+d_fp_classl='undef'
d_fpathconf='undef'
d_fpclass='undef'
d_fpclassify='undef'
d_fpclassl='undef'
+d_fpgetround='undef'
d_fpos64_t='undef'
d_frexpl='undef'
d_fs_data_s='undef'
d_isascii='define'
d_isblank='undef'
d_isfinite='undef'
+d_isfinitel='undef'
d_isinf='undef'
+d_isinfl='undef'
d_isnan='undef'
d_isnanl='undef'
+d_j0='undef'
+d_j0l='undef'
d_killpg='undef'
d_lchown='undef'
d_ldbl_dig='define'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
d_truncate='undef'
+d_truncl='undef'
d_ttyname_r='undef'
d_tzname='define'
d_u32align='undef'
i_dlfcn='define'
i_execinfo='undef'
i_fcntl='define'
+i_fenv='undef'
i_float='define'
i_fp='undef'
i_fp_class='undef'
i_prot='undef'
i_pthread='undef'
i_pwd='undef'
+i_quadmath='undef'
i_rpcsvcdbm='define'
i_sgtty='undef'
i_shadow='undef'
i_stdarg='define'
i_stdbool='define'
i_stddef='define'
+i_stdint='undef'
i_stdlib='define'
i_string='define'
i_sunmath='undef'
useopcode='true'
useperlio='undef'
useposix='true'
+usequadmath='undef'
usereentrant='undef'
userelocatableinc='undef'
useshrplib='true'
* 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.3\\lib\\NetWare-x86-multi-thread" /**/
+#define ARCHLIB "c:\\perl\\5.21.4\\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.3\\bin\\NetWare-x86-multi-thread" /**/
-#define BIN_EXP "c:\\perl\\5.21.3\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN "c:\\perl\\5.21.4\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN_EXP "c:\\perl\\5.21.4\\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.3\\lib\\NetWare-x86-multi-thread" /**/
+#define SITEARCH "c:\\perl\\site\\5.21.4\\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.3\\lib" /**/
+#define SITELIB "c:\\perl\\site\\5.21.4\\lib" /**/
/*#define SITELIB_EXP "" /**/
#define SITELIB_STEM "" /**/
This variable conditionally defines the HAS_ACCESSX symbol, which
indicates to the C program that the accessx() routine is available.
+d_acosh (d_acosh.U):
+ This variable conditionally defines the HAS_ACOSH symbol, which
+ indicates to the C program that the acosh() routine is available.
+
d_aintl (d_aintl.U):
This variable conditionally defines the HAS_AINTL symbol, which
indicates to the C program that the aintl() routine is available.
a half-fast job and neglected to provide the macros to manipulate
an fd_set, HAS_FDS_BITS will let us know how to fix the gaffe.
+d_fegetround (d_fegetround.U):
+ This variable conditionally defines HAS_FEGETROUND if fegetround() is
+ available to get the floating point rounding mode.
+
d_fgetpos (d_fgetpos.U):
This variable conditionally defines HAS_FGETPOS if fgetpos() is
available to get the file position indicator.
This variable conditionally defines the HAS_FP_CLASS symbol, which
indicates to the C program that the fp_class() routine is available.
+d_fp_classify (d_fpclassify.U):
+ This variable conditionally defines the HAS_FP_CLASSIFY symbol, which
+ indicates to the C program that the fp_classify() routine is available.
+
+d_fp_classl (d_fp_classl.U):
+ This variable conditionally defines the HAS_FP_CLASSL symbol, which
+ indicates to the C program that the fp_classl() routine is available.
+
d_fpathconf (d_pathconf.U):
This variable conditionally defines the HAS_FPATHCONF symbol, which
indicates to the C program that the pathconf() routine is available
This variable conditionally defines the HAS_FPCLASSL symbol, which
indicates to the C program that the fpclassl() routine is available.
+d_fpgetround (d_fpgetround.U):
+ This variable conditionally defines HAS_FPGETROUND if fpgetround()
+ is available to get the floating point rounding mode.
+
d_fpos64_t (d_fpos64_t.U):
This symbol will be defined if the C compiler supports fpos64_t.
This variable conditionally defines the HAS_ISFINITE symbol, which
indicates to the C program that the isfinite() routine is available.
+d_isfinitel (d_isfinitel.U):
+ This variable conditionally defines the HAS_ISFINITEL symbol, which
+ indicates to the C program that the isfinitel() routine is available.
+
d_isinf (d_isinf.U):
This variable conditionally defines the HAS_ISINF symbol, which
indicates to the C program that the isinf() routine is available.
+d_isinfl (d_isinfl.U):
+ This variable conditionally defines the HAS_ISINFL symbol, which
+ indicates to the C program that the isinfl() routine is available.
+
d_isnan (d_isnan.U):
This variable conditionally defines the HAS_ISNAN symbol, which
indicates to the C program that the isnan() routine is available.
This variable conditionally defines the HAS_ISNANL symbol, which
indicates to the C program that the isnanl() routine is available.
+d_j0 (d_j0.U):
+ This variable conditionally defines the HAS_J0 symbol, which
+ indicates to the C program that the j0() routine is available.
+
+d_j0l (d_j0.U):
+ This variable conditionally defines the HAS_J0L symbol, which
+ indicates to the C program that the j0l() routine is available.
+
d_killpg (d_killpg.U):
This variable conditionally defines the HAS_KILLPG symbol, which
indicates to the C program that the killpg() routine is available
header files provide LDBL_DIG, which is the number of significant
digits in a long double precision number.
-d_ldexpl (d_ldexpl.U):
+d_ldexpl (d_longdbl.U):
This variable conditionally defines the HAS_LDEXPL symbol, which
indicates to the C program that the ldexpl() routine is available.
This variable conditionally defines HAS_TRUNCATE if truncate() is
available to truncate files.
+d_truncl (d_truncl.U):
+ This variable conditionally defines the HAS_TRUNCL symbol, which
+ indicates to the C program that the truncl() routine is available
+ to round long doubles towards zero. If copysignl is also present,
+ we can emulate modfl.
+
d_ttyname_r (d_ttyname_r.U):
This variable conditionally defines the HAS_TTYNAME_R symbol,
which indicates to the C program that the ttyname_r()
This variable controls the value of I_FCNTL (which tells
the C program to include <fcntl.h>).
+i_fenv (i_fenv.U):
+ This variable conditionally defines the I_FENV symbol, which
+ indicates to the C program that <fenv.h> exists and should
+ be included.
+
i_float (i_float.U):
This variable conditionally defines the I_FLOAT symbol, and indicates
whether a C program may include <float.h> to get symbols like DBL_MAX
This variable conditionally defines I_PWD, which indicates
to the C program that it should include <pwd.h>.
+i_quadmath (i_quadmath.U):
+ This variable conditionally defines I_QUADMATH, which indicates
+ to the C program that it should include <quadmath.h>.
+
i_rpcsvcdbm (i_dbm.U):
This variable conditionally defines the I_RPCSVC_DBM symbol, which
indicates to the C program that <rpcsvc/dbm.h> exists and should
indicates to the C program that <stddef.h> exists and should
be included.
+i_stdint (i_stdint.U):
+ This variable conditionally defines the I_STDINT symbol, which
+ indicates to the C program that <stdint.h> exists and should
+ be included.
+
i_stdlib (i_stdlib.U):
This variable conditionally defines the I_STDLIB symbol, which
indicates to the C program that <stdlib.h> exists and should
libraries. It is prepended to libpth, and is intended to be easily
set from the command line.
-longdblkind (longdblkind.U):
+longdblkind (d_longdbl.U):
This variable, if defined, encodes the type of a long double:
0 = double, 1 = IEEE 754 128-bit big little endian,
2 = IEEE 754 128-bit big big endian, 3 = x86 80-bit little endian,
for hints files to indicate that POSIX will not compile
on a particular system.
+usequadmath (usequadmath.U):
+ This variable conditionally defines the USE_QUADMATH symbol,
+ and indicates that the quadmath library __float128 long doubles
+ should be used when available.
+
usereentrant (usethreads.U):
This variable conditionally defines the USE_REENTRANT_API symbol,
which indicates that the thread code may try to use the various
# complain if it can't find them)
@IGNORABLE = qw(
- .cvsignore .dualLivedDiffConfig .gitignore
+ .cvsignore .dualLivedDiffConfig .gitignore .perlcriticrc .perltidyrc
ANNOUNCE Announce Artistic AUTHORS BENCHMARK BUGS Build.PL
CHANGELOG ChangeLog Changelog CHANGES Changes CONTRIBUTING COPYING Copying
cpanfile CREDITS dist.ini GOALS HISTORY INSTALL INSTALL.SKIP LICENSE
Makefile.PL MANIFEST MANIFEST.SKIP META.json META.yml MYMETA.json
- MYMETA.yml NEW NOTES perlcritic.rc ppport.h README README.PATCHING
- SIGNATURE THANKS TODO Todo VERSION WHATSNEW .perlcriticrc.perltidyrc
+ MYMETA.yml NEW NEWS NOTES perlcritic.rc ppport.h README README.PATCHING
+ SIGNATURE THANKS TODO Todo VERSION WHATSNEW
);
# Each entry in the %Modules hash roughly represents a distribution,
%Modules = (
'Archive::Tar' => {
- 'DISTRIBUTION' => 'BINGOS/Archive-Tar-2.00.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Archive-Tar-2.02.tar.gz',
'FILES' => q[cpan/Archive-Tar],
'BUGS' => 'bug-archive-tar@rt.cpan.org',
'EXCLUDED' => [
},
'CPAN::Meta::Requirements' => {
- 'DISTRIBUTION' => 'DAGOLDEN/CPAN-Meta-Requirements-2.126.tar.gz',
+ 'DISTRIBUTION' => 'DAGOLDEN/CPAN-Meta-Requirements-2.128.tar.gz',
'FILES' => q[cpan/CPAN-Meta-Requirements],
'EXCLUDED' => [
qw(CONTRIBUTING.mkdn),
- qw(t/00-compile.t),
qw(t/00-report-prereqs.t),
qw(t/00-report-prereqs.dd),
+ qw(t/version-cleanup.t),
qr{^xt},
],
},
},
'Data::Dumper' => {
- 'DISTRIBUTION' => 'SMUELLER/Data-Dumper-2.151.tar.gz',
+ 'DISTRIBUTION' => 'SMUELLER/Data-Dumper-2.154.tar.gz',
'FILES' => q[dist/Data-Dumper],
},
examples/dups
),
],
+ # Was hoping to be merged upstream in CPAN RT#96498,
+ # but that has been rejected...
+ 'CUSTOMIZED' => ['hints/hpux.pl'],
},
'Dumpvalue' => {
},
'experimental' => {
- 'DISTRIBUTION' => 'LEONT/experimental-0.008.tar.gz',
+ 'DISTRIBUTION' => 'LEONT/experimental-0.010.tar.gz',
'FILES' => q[cpan/experimental],
'EXCLUDED' => [
qr{^t/release-.*\.t},
},
'ExtUtils::CBuilder' => {
- 'DISTRIBUTION' => 'AMBS/ExtUtils/ExtUtils-CBuilder-0.280216.tar.gz',
+ 'DISTRIBUTION' => 'AMBS/ExtUtils-CBuilder-0.280219.tar.gz',
'FILES' => q[dist/ExtUtils-CBuilder],
'EXCLUDED' => [
qw(README.mkdn),
},
'ExtUtils::Install' => {
- 'DISTRIBUTION' => 'BINGOS/ExtUtils-Install-1.68.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/ExtUtils-Install-2.04.tar.gz',
'FILES' => q[cpan/ExtUtils-Install],
'EXCLUDED' => [
qw( t/lib/Test/Builder.pm
'PATCHING',
'README.packaging',
],
+ 'CUSTOMIZED' => [
+ # Already merged upstream in GitHub 0116aaf4e, just awaiting
+ # a new stable CPAN release
+ qw( t/pm_to_blib.t ),
+ # Already merged upstream in GitHub 46586b12c, just awaiting
+ # a new stable CPAN release
+ qw( lib/ExtUtils/Liblist/Kid.pm ),
+ ],
},
'ExtUtils::Manifest' => {
- 'DISTRIBUTION' => 'BINGOS/ExtUtils-Manifest-1.65.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/ExtUtils-Manifest-1.68.tar.gz',
'FILES' => q[cpan/ExtUtils-Manifest],
'EXCLUDED' => [qr(^xt/)],
},
},
'HTTP::Tiny' => {
- 'DISTRIBUTION' => 'DAGOLDEN/HTTP-Tiny-0.047.tar.gz',
+ 'DISTRIBUTION' => 'DAGOLDEN/HTTP-Tiny-0.049.tar.gz',
'FILES' => q[cpan/HTTP-Tiny],
'EXCLUDED' => [
't/00-report-prereqs.t',
},
'IO::Socket::IP' => {
- 'DISTRIBUTION' => 'PEVANS/IO-Socket-IP-0.31.tar.gz',
+ 'DISTRIBUTION' => 'PEVANS/IO-Socket-IP-0.32.tar.gz',
'FILES' => q[cpan/IO-Socket-IP],
'EXCLUDED' => [
qr{^examples/},
},
'Locale-Codes' => {
- 'DISTRIBUTION' => 'SBECK/Locale-Codes-3.31.tar.gz',
+ 'DISTRIBUTION' => 'SBECK/Locale-Codes-3.32.tar.gz',
'FILES' => q[cpan/Locale-Codes],
'EXCLUDED' => [
qw( README.first
},
'Module::CoreList' => {
- 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.021002.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20140914.tar.gz',
'FILES' => q[dist/Module-CoreList],
},
},
'Pod::Perldoc' => {
- 'DISTRIBUTION' => 'MALLEN/Pod-Perldoc-3.23.tar.gz',
+ 'DISTRIBUTION' => 'MALLEN/Pod-Perldoc-3.24.tar.gz',
'FILES' => q[cpan/Pod-Perldoc],
# Note that we use the CPAN-provided Makefile.PL, since it
},
'Scalar-List-Utils' => {
- 'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.39.tar.gz',
+ 'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.41.tar.gz',
'FILES' => q[cpan/Scalar-List-Utils],
},
},
'Socket' => {
- 'DISTRIBUTION' => 'PEVANS/Socket-2.014.tar.gz',
+ 'DISTRIBUTION' => 'PEVANS/Socket-2.015.tar.gz',
'FILES' => q[cpan/Socket],
},
},
'Test::Harness' => {
- 'DISTRIBUTION' => 'LEONT/Test-Harness-3.32.tar.gz',
+ 'DISTRIBUTION' => 'LEONT/Test-Harness-3.33.tar.gz',
'FILES' => q[cpan/Test-Harness],
'EXCLUDED' => [
qr{^examples/},
},
'Test::Simple' => {
- 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.001003.tar.gz',
+ 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.001006.tar.gz',
'FILES' => q[cpan/Test-Simple],
'EXCLUDED' => [
qr{^t/xt},
},
'threads' => {
- 'DISTRIBUTION' => 'JDHEDDEN/threads-1.92.tar.gz',
+ 'DISTRIBUTION' => 'JDHEDDEN/threads-1.96.tar.gz',
'FILES' => q[dist/threads],
'EXCLUDED' => [
qr{^examples/},
},
'Time::Piece' => {
- 'DISTRIBUTION' => 'RJBS/Time-Piece-1.27.tar.gz',
+ 'DISTRIBUTION' => 'RJBS/Time-Piece-1.29.tar.gz',
'FILES' => q[cpan/Time-Piece],
},
},
'version' => {
- 'DISTRIBUTION' => 'JPEACOCK/version-0.9908.tar.gz',
+ 'DISTRIBUTION' => 'JPEACOCK/version-0.9909.tar.gz',
'FILES' => q[cpan/version vutil.c vutil.h vxs.inc],
'EXCLUDED' => [
qr{^vutil/lib/},
# Merged upstream, waiting for new CPAN release: see CPAN RT#92721
qw( vutil.c
- vxs.inc
),
],
lib/AnyDBM_File.{pm,t}
lib/Benchmark.{pm,t}
lib/B/Deparse{.pm,.t,-core.t}
+ lib/B/Op_private.pm
lib/CORE.pod
lib/Class/Struct.{pm,t}
lib/Config.t
F<miniperl> is built. If C<--all-fixups> is specified, all the fixups are
done before running C<Configure>. In rare cases adding this may cause a
bisect to abort, because an inapplicable patch or other fixup is attempted
-for a revision which would usually have already I<skip>ed. If this happens,
+for a revision which would usually have already I<skip>ped. If this happens,
please report it as a bug, giving the OS and problem revision.
=item *
END {
my $end_time = time;
- printf "That took %d seconds\n", $end_time - $start_time
+ printf "That took %d seconds.\n", $end_time - $start_time
if defined $start_time;
}
my %skip_versions = (
# 'some/sample/file.pm' => [ '1.23', '1.24' ],
- 'dist/threads/lib/threads.pm' => [ '1.83' ],
);
my $skip_dirs = qr|^t/lib|;
# look for a .pm in lib/ based on that:
my ($path) = shift =~ m!^(.*)/!;
my ($last) = $path =~ m!([^/]+)\z!;
+ $last = 'List-Util' if $last eq 'Scalar-List-Utils';
$last =~ tr !-!/!;
return "$path/lib/$last";
}) {
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='3'
+api_subversion='4'
api_version='21'
-api_versionstring='5.21.3'
+api_versionstring='5.21.4'
ar='ar'
-archlib='/pro/lib/perl5/5.21.3/i686-linux-64int'
-archlibexp='/pro/lib/perl5/5.21.3/i686-linux-64int'
+archlib='/pro/lib/perl5/5.21.4/i686-linux-64int'
+archlibexp='/pro/lib/perl5/5.21.4/i686-linux-64int'
archname64='64int'
archname='i686-linux-64int'
archobjs=''
d__fwalk='undef'
d_access='define'
d_accessx='undef'
+d_acosh='undef'
d_aintl='undef'
d_alarm='define'
d_archlib='define'
d_fd_macros='define'
d_fd_set='define'
d_fds_bits='undef'
+d_fegetround='undef'
d_fgetpos='define'
d_finite='define'
d_finitel='define'
d_flockproto='define'
d_fork='define'
d_fp_class='undef'
+d_fp_classify='undef'
+d_fp_classl='undef'
d_fpathconf='define'
d_fpclass='undef'
d_fpclassify='undef'
d_fpclassl='undef'
+d_fpgetround='undef'
d_fpos64_t='undef'
d_frexpl='define'
d_fs_data_s='undef'
d_isascii='define'
d_isblank='define'
d_isfinite='undef'
+d_isfinitel='undef'
d_isinf='define'
+d_isinfl='undef'
d_isnan='define'
d_isnanl='define'
+d_j0='undef'
+d_j0l='undef'
d_killpg='define'
d_lchown='define'
d_ldbl_dig='define'
d_tm_tm_zone='define'
d_tmpnam_r='undef'
d_truncate='define'
+d_truncl='undef'
d_ttyname_r='undef'
d_tzname='define'
d_u32align='define'
i_dlfcn='define'
i_execinfo='undef'
i_fcntl='undef'
+i_fenv='undef'
i_float='define'
i_fp='undef'
i_fp_class='undef'
i_prot='undef'
i_pthread='define'
i_pwd='define'
+i_quadmath='undef'
i_rpcsvcdbm='undef'
i_sgtty='undef'
i_shadow='define'
i_stdarg='define'
i_stdbool='define'
i_stddef='define'
+i_stdint='undef'
i_stdlib='define'
i_string='define'
i_sunmath='undef'
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.3/i686-linux-64int'
+installarchlib='/pro/lib/perl5/5.21.4/i686-linux-64int'
installbin='/pro/bin'
installhtml1dir=''
installhtml3dir=''
installman3dir='/pro/local/man/man3'
installprefix='/pro'
installprefixexp='/pro'
-installprivlib='/pro/lib/perl5/5.21.3'
+installprivlib='/pro/lib/perl5/5.21.4'
installscript='/pro/bin'
-installsitearch='/pro/lib/perl5/site_perl/5.21.3/i686-linux-64int'
+installsitearch='/pro/lib/perl5/site_perl/5.21.4/i686-linux-64int'
installsitebin='/pro/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='/pro/lib/perl5/site_perl/5.21.3'
+installsitelib='/pro/lib/perl5/site_perl/5.21.4'
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.3'
+perlpath='/pro/bin/perl5.21.4'
pg='pg'
phostname='hostname'
pidtype='pid_t'
pr=''
prefix='/pro'
prefixexp='/pro'
-privlib='/pro/lib/perl5/5.21.3'
-privlibexp='/pro/lib/perl5/5.21.3'
+privlib='/pro/lib/perl5/5.21.4'
+privlibexp='/pro/lib/perl5/5.21.4'
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.3/i686-linux-64int'
-sitearchexp='/pro/lib/perl5/site_perl/5.21.3/i686-linux-64int'
+sitearch='/pro/lib/perl5/site_perl/5.21.4/i686-linux-64int'
+sitearchexp='/pro/lib/perl5/site_perl/5.21.4/i686-linux-64int'
sitebin='/pro/bin'
sitebinexp='/pro/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/pro/lib/perl5/site_perl/5.21.3'
+sitelib='/pro/lib/perl5/site_perl/5.21.4'
sitelib_stem='/pro/lib/perl5/site_perl'
-sitelibexp='/pro/lib/perl5/site_perl/5.21.3'
+sitelibexp='/pro/lib/perl5/site_perl/5.21.4'
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.3'
+startperl='#!/pro/bin/perl5.21.4'
startsh='#!/bin/sh'
static_ext=' '
stdchar='char'
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='3'
+subversion='4'
sysman='/usr/share/man/man1'
sysroot=''
tail=''
useopcode='true'
useperlio='define'
useposix='true'
+usequadmath='undef'
usereentrant='undef'
userelocatableinc='undef'
useshrplib='false'
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.21.3'
-version_patchlevel_string='version 21 subversion 3'
+version='5.21.4'
+version_patchlevel_string='version 21 subversion 4'
versiononly='define'
vi=''
xlibpth='/usr/lib/386 /lib/386'
zip='zip'
PERL_REVISION=5
PERL_VERSION=21
-PERL_SUBVERSION=3
+PERL_SUBVERSION=4
PERL_API_REVISION=5
PERL_API_VERSION=21
-PERL_API_SUBVERSION=3
+PERL_API_SUBVERSION=4
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.3/i686-linux-64int-ld" /**/
-#define ARCHLIB_EXP "/pro/lib/perl5/5.21.3/i686-linux-64int-ld" /**/
+#define ARCHLIB "/pro/lib/perl5/5.21.4/i686-linux-64int-ld" /**/
+#define ARCHLIB_EXP "/pro/lib/perl5/5.21.4/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.3" /**/
-#define PRIVLIB_EXP "/pro/lib/perl5/5.21.3" /**/
+#define PRIVLIB "/pro/lib/perl5/5.21.4" /**/
+#define PRIVLIB_EXP "/pro/lib/perl5/5.21.4" /**/
/* 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.3/i686-linux-64int-ld" /**/
-#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.21.3/i686-linux-64int-ld" /**/
+#define SITEARCH "/pro/lib/perl5/site_perl/5.21.4/i686-linux-64int-ld" /**/
+#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.21.4/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.3" /**/
-#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.21.3" /**/
+#define SITELIB "/pro/lib/perl5/site_perl/5.21.4" /**/
+#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.21.4" /**/
#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.3" /**/
+#define STARTPERL "#!/pro/bin/perl5.21.4" /**/
/* HAS_STDIO_STREAM_ARRAY:
* This symbol, if defined, tells that there is an array
=head1 EPIGRAPHS
+=head2 v5.20.1 - Lorenzo da Ponte, Così fan tutte
+
+L<Announced on 2014-09-14 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2014/09/msg219789.html>
+
+ DORABELLA (as if waking from a daze): Where are they?
+ DON ALFONSO: They've gone.
+ FIORDILIGI: Oh, the cruel bitterness of parting!
+
+ DON ALFONSO:
+ Take heart, my dearest children.
+ Look, in the distance, your lovers are waving to you.
+
+ FIORDILIGI: Bon voyage, my darling!
+ DORABELLA: Bon voyage!
+
+ FIORDILIGI:
+ O heavens! How swiftly the ship is sailing away!
+ It is disappearing already!
+ It is no longer in sight!
+ Oh, may heaven grant it a prosperous voyage!
+
+ DORABELLA: May good luck attend it to the battlefield!
+ DON ALFONSO: And may your sweethearts and my friends be safe!
+
+ FIORDILIGI, DORABELLA, DON ALFONSO:
+ May the wind be gentle,
+ may the sea be calm,
+ and may the elements
+ respond kindly
+ to our wishes.
+
+ -- Lorenzo da Ponte, /Così fan tutte/,
+ trans. Diana Reed
+
+=head2 v5.20.1-RC2 - Lorenzo da Ponte, Così fan tutte
+
+L<Announced on 2014-09-07 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2014/09/msg219446.html>
+
+ GUGLIELMO:
+ Oh God, I feel that this foot of mine
+ is reluctant to come before her.
+
+ FERRANDO:
+ My trembling lip
+ can utter no word.
+
+ DON ALFONSO:
+ The hero displays his manliness
+ in the most terrible moments.
+
+ FIORDILIGI, DORABELLA:
+ Now that we have heard the news,
+ you have the lesser duty:
+ Take heart, and plunge your swords
+ into both our hearts.
+
+ FERRANDO, GUGLIELMO:
+ My idol, blame fate
+ that I must abandon you.
+
+ DORABELLA: Ah no, you shall not leave...
+ FIORDILIGI: No, cruel one, you shall not go...
+ DORABELLA: First I want to tear out my heart.
+ FIORDILIGI: First I want to die at your feet.
+ FERRANDO (softly to Don Alfonso): What do you say to that?
+ GUGLIELMO (softly to Don Alfonso): You realise?
+ DON ALFONSO (softly): Steady, friend, finem lauda.
+
+ ALL:
+ Thus destiny defrauds
+ the hopes of mortals.
+ Ah, among so many misfortunes,
+ who can ever love life?
+
+ -- Lorenzo da Ponte, /Così fan tutte/,
+ trans. William Weaver
+
+=head2 v5.20.1-RC1 - Lorenzo da Ponte, Così fan tutte
+
+L<Announced on 2014-08-25 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2014/08/msg218975.html>
+
+ DON ALFONSO:
+ I'd like to speak, but I haven't the heart:
+ my lip stammers.
+ My voice cannot emerge,
+ but remains in my throat.
+ What will you do? What shall I do?
+ Oh what a great catastrophe!
+ There can be nothing worse.
+ I feel pity for you and for them.
+
+ FIORDILIGI: Heavens! For mercy's sake, Signor Alfonso, don't make us
+ die.
+ DON ALFONSO: My children, you must arm yourselves with constancy.
+ DORABELLA: Ye Gods! What evil has occurred? What horrible event? Is my
+ love dead, perhaps?
+ FIORDILIGI: Is mine dead?
+ DON ALFONSO: They are not dead, but they are not far from it.
+ DORABELLA: Wounded?
+ DON ALFONSO: No.
+ FIORDILIGI: Ill?
+ DON ALFONSO: Nor that.
+ FIORDILIGI: What, then?
+ DON ALFONSO: A royal command summons them to the field of battle.
+ FIORDILIGI, DORABELLA: Alas, what do I hear? And they will leave?
+ DON ALFONSO: Immediately.
+ DORABELLA: And there is no way of preventing it?
+ DON ALFONSO: There is none.
+ FIORDILIGI: And not even a single farewell...
+ DON ALFONSO: The unhappy men haven't the courage to see you; but if
+ you wish it, they are ready...
+ DORABELLA: Where are they?
+ DON ALFONSO: Come in, friends.
+
+ -- Lorenzo da Ponte, /Così fan tutte/,
+ trans. William Weaver
+
+=head2 v5.21.3 - Robert Service, The Men that Don't Fit In
+
+L<Announced on 2014-08-20 by Peter Martini|http://www.nntp.perl.org/group/perl.perl5.porters/2014/08/msg218826.html>
+
+ If they just went straight they might go far,
+ They are strong and brave and true;
+ But they're always tired of the things that are,
+ And they want the strange and new.
+ They say: "Could I find my proper groove,
+ What a deep mark I would make!"
+ So they chop and change, and each fresh move
+ Is only a fresh mistake.
+
=head2 v5.21.2 - Neil Armstrong, Buzz Aldrin, Charlie Duke, Final minutes of communication of the first manned moon landing, July 20, 1969.
L<Announced on 2014-07-20 by Abigail|http://www.nntp.perl.org/group/perl.perl5.porters/2014/07/msg217937.html>
XXX Generate this with:
- perl Porting/acknowledgements.pl v5.21.3..HEAD
+ perl Porting/acknowledgements.pl v5.21.4..HEAD
=head1 Reporting Bugs
-- [ATTRIBUTION]
We are [SYNONYM FOR 'pleased'] to announce version [VERSION.SUBVERSION],
-the [N-TH] development release of version 19 of Perl 5.
+the [N-TH] development release of version [VERSION] of Perl 5.
You will soon be able to download Perl 5.[VERSION.SUBVERSION] from your
favorite CPAN mirror or find it at:
[ACKNOWLEDGEMENTS SECTION FROM PERLDELTA]
We expect to release version [NEXT BLEAD VERSION.SUBVERSION] on [FUTURE
-DATE]. The next major stable release of Perl 5, version 20.0, should
-appear in May 2014.
+DATE]. The next major stable release of Perl 5, version 22.0, should
+appear in May 2015.
[YOUR SALUTATION HERE]
=head2 Perl 5.20
2014-05-27 5.20.0 ✓ Ricardo Signes
- 2014-08-?? 5.20.1 Steve Hay
+ 2014-09-14 5.20.1 ✓ Steve Hay
+ 2015-01-?? 5.20.2 Steve Hay
=head2 Perl 5.18
-Release schedule (with release manager):
-
2013-05-18 5.18.0 ✓ Ricardo Signes
2013-08-12 5.18.1 ✓ Ricardo Signes
2014-01-06 5.18.2 ✓ Ricardo Signes
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-07-20 5.21.2 ✓ Abigail
+ 2014-08-20 5.21.3 ✓ Peter Martini
2014-09-20 5.21.4 Steve Hay
- 2014-10-20 5.21.5 ?
- 2014-11-20 5.21.6 ?
- 2014-12-20 5.21.7 ?
- 2015-01-20 5.21.8 ?
+ 2014-10-20 5.21.5 Abigail
+ 2014-11-20 5.21.6 Chris "BinGOs" Williams
+ 2014-12-20 5.21.7 Max Maischein
+ 2015-01-20 5.21.8 Matthew Horsfall
2015-02-20 5.21.9 ?
2015-03-20 5.21.10 ?
2015-04-20 5.21.11 ?
Jesse Vincent <jesse@cpan.org>
Leon Brocard <acme@astray.com>
Matt Trout <mst@shadowcat.co.uk>
+Matthew Horsfall <wolfsage@gmail.com>
Max Maischein <corion@cpan.org>
+Peter Martini <petercmartini@gmail.com>
Philippe Bruhat <book@cpan.org>
Ricardo Signes <rjbs@cpan.org>
Stevan Little <stevan.little@iinteractive.com>
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.3.
+options would be nice for perl 5.21.4.
=head2 Profile Perl - am I hot or not?
=head2 Virtualize operating system access
Implement a set of "vtables" that virtualizes operating system access
-(open(), mkdir(), unlink(), readdir(), getenv(), etc.) At the very
-least these interfaces should take SVs as "name" arguments instead of
-bare char pointers; probably the most flexible and extensible way
-would be for the Perl-facing interfaces to accept HVs. The system
-needs to be per-operating-system and per-file-system
-hookable/filterable, preferably both from XS and Perl level
-(L<perlport/"Files and Filesystems"> is good reading at this point,
-in fact, all of L<perlport> is.)
+(chdir(), chmod(), dbmopen(), getenv(), glob(), link(), mkdir(), open(),
+opendir(), readdir(), rename(), rmdir(), stat(), sysopen(), uname(),
+unlink(), etc.) At the very least these interfaces should take SVs as
+"name" arguments instead of bare char pointers; probably the most
+flexible and extensible way would be for the Perl-facing interfaces to
+accept HVs. The system needs to be per-operating-system and
+per-file-system hookable/filterable, preferably both from XS and Perl
+level (L<perlport/"Files and Filesystems"> is good reading at this
+point, in fact, all of L<perlport> is.)
This has actually already been implemented (but only for Win32),
take a look at F<iperlsys.h> and F<win32/perlhost.h>. While all Win32
=head1 Big projects
Tasks that will get your name mentioned in the description of the "Highlights
-of 5.21.3"
+of 5.21.4"
=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.3/BePC-haiku/CORE/libperl.so .
+ cd /boot/common/lib; ln -s perl5/5.21.4/BePC-haiku/CORE/libperl.so .
-Replace C<5.21.3> with your respective version of Perl.
+Replace C<5.21.4> with your respective version of Perl.
=head1 KNOWN PROBLEMS
This document briefly describes Perl under Mac OS X.
- curl -O http://www.cpan.org/src/perl-5.21.3.tar.gz
- tar -xzf perl-5.21.3.tar.gz
- cd perl-5.21.3
+ curl -O http://www.cpan.org/src/perl-5.21.4.tar.gz
+ tar -xzf perl-5.21.4.tar.gz
+ cd perl-5.21.4
./Configure -des -Dprefix=/usr/local/
make
make test
=head1 DESCRIPTION
-The latest Perl release (5.21.3 as of this writing) builds without changes
+The latest Perl release (5.21.4 as of this writing) builds without changes
under all versions of Mac OS X from 10.3 "Panther" onwards.
In order to build your own version of Perl you will need 'make',
=item Additional Perl modules
- unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.21.3/
+ unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.21.4/
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^.3.tar
+ vmstar -xvf perl-5^.21^.4.tar
Then set default to the top-level source directory like so:
- set default [.perl-5^.21^.3]
+ set default [.perl-5^.21^.4]
and proceed with configuration as described in the next section.
} else {
# (likely) we're being run by t/TEST or t/harness, and we're a test
# in t/
- @INC = '../lib';
+ if (defined &DynaLoader::boot_DynaLoader) {
+ @INC = '../lib';
+ }
+ else {
+ # miniperl/minitest
+ # t/TEST does not supply -I../lib, so buildcustomize.pl is
+ # not automatically included.
+ unshift @INC, '../lib';
+ do "../lib/buildcustomize.pl";
+ }
}
}
;;
esac
+# The quadmath Q format specifier will cause -Wformat to whine.
+case "$gccversion" in
+'') ;;
+*) case "$usequadmath" in
+ define)
+ for f in -Wno-format
+ do
+ echo "cflags.SH: Adding $f because of usequadmath."
+ warn="$warn $f"
+ done
+ ;;
+ esac
+ ;;
+esac
+
case "$cc" in
*g++*)
# Extra paranoia in case people have bad canned ccflags:
* C preprocessor can make decisions based on it. It is only
* defined if the system supports long doubles.
*/
+/* HAS_LDEXPL:
+ * This symbol, if defined, indicates that the ldexpl routine is
+ * available to shift a long double floating-point number
+ * by an integral power of 2.
+ */
/* LONG_DOUBLEKIND:
* LONG_DOUBLEKIND will be one of
* LONG_DOUBLE_IS_DOUBLE
* LONG_DOUBLE_IS_UNKNOWN_FORMAT
* It is only defined if the system supports long doubles.
*/
+#$d_ldexpl HAS_LDEXPL /**/
#$d_longdbl HAS_LONG_DOUBLE /**/
#ifdef HAS_LONG_DOUBLE
#define LONG_DOUBLESIZE $longdblsize /**/
#$d_pwgecos PWGECOS /**/
#$d_pwpasswd PWPASSWD /**/
+/* I_QUADMATH:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <quadmath.h>.
+ */
+#$i_quadmath I_QUADMATH /**/
+
/* I_SYS_ACCESS:
* This symbol, if defined, indicates to the C program that it should
* include <sys/access.h>.
*/
#$d__fwalk HAS__FWALK /**/
+/* HAS_ACOSH:
+ * This symbol, if defined, indicates that the acosh routine is
+ * available to do the inverse hyperbolic cosine function.
+ */
+#$d_acosh HAS_ACOSH /**/
+
/* HAS_AINTL:
* This symbol, if defined, indicates that the aintl routine is
* available. If copysignl is also present we can emulate modfl.
*/
#$d_fcntl_can_lock FCNTL_CAN_LOCK /**/
+/* HAS_FEGETROUND:
+ * This symbol, if defined, indicates that the fegetround routine is
+ * available to return the macro corresponding to the current rounding
+ * mode.
+ */
+#$d_fegetround HAS_FEGETROUND /**/
+
/* HAS_FINITE:
* This symbol, if defined, indicates that the finite routine is
* available to check whether a double is finite (non-infinity non-NaN).
*/
#$d_fp_class HAS_FP_CLASS /**/
+/* HAS_FP_CLASSL:
+ * This symbol, if defined, indicates that the fp_classl routine is
+ * available to classify long doubles. Available for example in
+ * Digital UNIX. See for possible values HAS_FP_CLASS.
+ */
+#$d_fp_classl HAS_FP_CLASSL /**/
+
/* HAS_FPCLASS:
* This symbol, if defined, indicates that the fpclass routine is
* available to classify doubles. Available for example in Solaris/SVR4.
* FP_NAN NaN
*
*/
-#$d_fpclassify HAS_FPCLASSIFY /**/
+/* HAS_FP_CLASSIFY:
+ * This symbol, if defined, indicates that the fp_classify routine is
+ * available to classify doubles. The values are defined in <math.h>
+ *
+ * FP_NORMAL Normalized
+ * FP_ZERO Zero
+ * FP_INFINITE Infinity
+ * FP_SUBNORMAL Denormalized
+ * FP_NAN NaN
+ *
+ */
+#$d_fpclassify HAS_FPCLASSIFY /**/
+#$d_fp_classify HAS_FP_CLASSIFY /**/
/* HAS_FPCLASSL:
* This symbol, if defined, indicates that the fpclassl routine is
*/
#$d_fpclassl HAS_FPCLASSL /**/
+/* HAS_FPGETROUND:
+ * This symbol, if defined, indicates that the fpgetround routine is
+ * available to get the floating point rounding mode.
+ */
+#$d_fpgetround HAS_FPGETROUND /**/
+
/* HAS_FPOS64_T:
* This symbol will be defined if the C compiler supports fpos64_t.
*/
*/
#$d_frexpl HAS_FREXPL /**/
-/* HAS_LDEXPL:
- * This symbol, if defined, indicates that the ldexpl routine is
- * available to shift a long double floating-point number
- * by an integral power of 2.
- */
-#$d_ldexpl HAS_LDEXPL /**/
-
/* HAS_STRUCT_FS_DATA:
* This symbol, if defined, indicates that the struct fs_data
* to do statfs() is supported.
*/
#$d_isfinite HAS_ISFINITE /**/
+/* HAS_ISFINITEL:
+ * This symbol, if defined, indicates that the isfinitel routine is
+ * available to check whether a long double is finite.
+ * (non-infinity non-NaN).
+ */
+#$d_isfinitel HAS_ISFINITEL /**/
+
/* HAS_ISINF:
* This symbol, if defined, indicates that the isinf routine is
* available to check whether a double is an infinity.
*/
#$d_isinf HAS_ISINF /**/
+/* HAS_ISINFL:
+ * This symbol, if defined, indicates that the isinfl routine is
+ * available to check whether a long double is an infinity.
+ */
+#$d_isinfl HAS_ISINFL /**/
+
/* HAS_ISNAN:
* This symbol, if defined, indicates that the isnan routine is
* available to check whether a double is a NaN.
*/
#$d_isnanl HAS_ISNANL /**/
+/* HAS_J0:
+ * This symbol, if defined, indicates to the C program that the
+ * j0() function is available for Bessel functions of the first
+ * kind of the order zero, for doubles.
+ */
+/* HAS_J0L:
+ * This symbol, if defined, indicates to the C program that the
+ * j0l() function is available for Bessel functions of the first
+ * kind of the order zero, for long doubles.
+ */
+#$d_j0 HAS_J0 /**/
+#$d_j0l HAS_J0L /**/
+
/* HAS_LDBL_DIG:
* This symbol, if defined, indicates that this system's <float.h>
* or <limits.h> defines the symbol LDBL_DIG, which is the number
*/
#$d_timegm HAS_TIMEGM /**/
+/* HAS_TRUNCL:
+ * This symbol, if defined, indicates that the truncl routine is
+ * available. If copysignl is also present we can emulate modfl.
+ */
+#$d_truncl HAS_TRUNCL /**/
+
/* U32_ALIGNMENT_REQUIRED:
* This symbol, if defined, indicates that you must access
* character data through U32-aligned pointers.
#define DB_VERSION_MINOR_CFG $db_version_minor /**/
#define DB_VERSION_PATCH_CFG $db_version_patch /**/
+/* I_FENV:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <fenv.h> to get the floating point environment definitions.
+ */
+#$i_fenv I_FENV /**/
+
/* I_FP:
* This symbol, if defined, indicates that <fp.h> exists and
* should be included.
*/
#$i_stdbool I_STDBOOL /**/
+/* I_STDINT:
+ * This symbol, if defined, indicates that <stdint.h> exists and
+ * should be included.
+ */
+#$i_stdint I_STDINT /**/
+
/* I_SUNMATH:
* This symbol, if defined, indicates that <sunmath.h> exists and
* should be included.
#$uselongdouble USE_LONG_DOUBLE /**/
#endif
+/* USE_QUADMATH:
+ * This symbol, if defined, indicates that the quadmath library should
+ * be used when available.
+ */
+#ifndef USE_QUADMATH
+#$usequadmath USE_QUADMATH /**/
+#endif
+
/* USE_MORE_BITS:
* This symbol, if defined, indicates that 64-bit interfaces and
* long doubles should be used when available.
$heavy_txt .= "${prefix}_nolargefiles='$value'\n";
}
+if (open(my $fh, "cflags")) {
+ my $ccwarnflags;
+ my $ccstdflags;
+ while (<$fh>) {
+ if (/^warn="(.+)"$/) {
+ $ccwarnflags = $1;
+ } elsif (/^stdflags="(.+)"$/) {
+ $ccstdflags = $1;
+ }
+ }
+ if (defined $ccwarnflags) {
+ $heavy_txt .= "ccwarnflags='$ccwarnflags'\n";
+ }
+ if (defined $ccstdflags) {
+ $heavy_txt .= "ccstdflags='$ccstdflags'\n";
+ }
+}
+
$heavy_txt .= "EOVIRTUAL\n";
$heavy_txt .= <<'ENDOFGIT';
$ THEN
$ d_isnan = "define"
$ d_isnanl = "define"
+$ d_fp_classify = "define"
+$ d_j0 = "define"
+$ d_acosh = "define"
+$ d_truncl = "define"
$ ELSE
$ d_isnan = "undef"
$ d_isnanl = "undef"
+$ d_fp_classify = "undef"
+$ d_j0 = "undef"
+$ d_acosh = "undef"
+$ d_truncl = "undef"
$ ENDIF
$!
$! Now some that we build up
$ WC "d__fwalk='undef'"
$ WC "d_access='" + d_access + "'"
$ WC "d_accessx='undef'"
+$ WC "d_acosh='" + d_acosh + "'"
$ WC "d_aintl='undef'"
$ WC "d_alarm='define'"
$ WC "d_archlib='define'"
$ WC "d_fd_set='" + d_fd_set + "'"
$ WC "d_fd_macros='define'"
$ WC "d_fds_bits='define'"
+$ WC "d_fegetround='undef'"
$ WC "d_fgetpos='define'"
$ IF F$ELEMENT(0, "-", archname) .NES. "VMS_VAX" .AND. use_ieee_math
$ THEN
$ WC "d_flockproto='undef'"
$ WC "d_fork='undef'"
$ WC "d_fp_class='undef'"
+$ WC "d_fp_classify='" + d_fp_classify + "'"
+$ WC "d_fp_classify='undef'"
+$ WC "d_fp_classl='undef'"
$ WC "d_fpathconf='" + d_fpathconf + "'"
$ WC "d_fpclass='undef'"
$ WC "d_fpclassify='undef'"
$ WC "d_fpclassl='undef'"
+$ WC "d_fpgetround='undef'"
$ WC "d_fpos64_t='" + d_fpos64_t + "'"
$ WC "d_frexpl='" + d_frexpl + "'"
$ WC "d_fs_data_s='undef'"
$ WC "d_ipv6_mreq_source='undef'"
$ WC "d_isascii='define'"
$ WC "d_isblank='undef'"
-$ IF F$ELEMENT(0, "-", archname) .NES. "VMS_VAX" .AND. use_ieee_math
-$ THEN
-$ WC "d_isfinite='define'"
-$ ELSE
-$ WC "d_isfinite='undef'"
-$ ENDIF
+$ WC "d_isfinite='undef'"
+$ WC "d_isfinitel='undef'"
$ WC "d_isinf='undef'"
+$ WC "d_isinfl='undef'"
$ WC "d_isnan='" + d_isnan + "'"
$ WC "d_isnanl='" + d_isnanl + "'"
+$ WC "d_j0='" + d_j0 + "'"
+$ WC "d_j0l='undef'"
$ WC "d_killpg='undef'"
$ WC "d_lchown='" + d_lchown + "'"
$ WC "d_ldbl_dig='define'"
$ WC "d_tm_tm_zone='undef'"
$ ENDIF
$ WC "d_truncate='" + d_truncate + "'"
+$ WC "d_truncl='" + d_truncl + "'"
$ WC "d_tzname='" + d_tzname + "'"
$ WC "d_u32align='define'"
$ WC "d_ualarm='" + d_ualarm + "'"
$ WC "i_dlfcn='undef'"
$ WC "i_execinfo='undef'"
$ WC "i_fcntl='" + i_fcntl + "'"
+$ WC "i_fenv='undef'"
$ WC "i_float='define'"
$ WC "i_fp='undef'"
$ WC "i_fp_class='undef'"
$ WC "i_prot='undef'"
$ WC "i_pthread='define'"
$ WC "i_pwd='undef'"
+$ WC "i_quadmath='undef'"
$ WC "i_rpcsvcdbm='undef'"
$ WC "i_sgtty='undef'"
$ WC "i_shadow='" + i_shadow + "'"
$ WC "i_stdbool='undef'"
$ ENDIF
$ WC "i_stddef='define'"
+$ WC "i_stdint='undef'"
$ WC "i_stdlib='define'"
$ WC "i_string='define'"
$ WC "i_sunmath='undef'"
$ WC "usemymalloc='" + usemymalloc + "'"
$ WC "useperlio='define'"
$ WC "useposix='false'"
+$ WC "usequadmath='undef'"
$ WC "usereentrant='undef'"
$ WC "userelocatableinc='undef'"
$ WC "usesecurelog='" + usesecurelog + "'" ! VMS-specific
$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
-$VERSION = "2.00";
+$VERSION = "2.02";
$CHOWN = 1;
$CHMOD = 1;
$SAME_PERMISSIONS = $> == 0 ? 1 : 0;
BEGIN {
require Exporter;
- $VERSION = '2.00';
+ $VERSION = '2.02';
@ISA = qw[Exporter];
require Time::Local if $^O eq "MacOS";
use vars qw[@ISA $VERSION];
#@ISA = qw[Archive::Tar];
-$VERSION = '2.00';
+$VERSION = '2.02';
### set value to 1 to oct() it during the unpack ###
use Archive::Tar;
# filenames
-my $tartest = File::Spec->catfile("t", "tartest");
-my $foo = File::Spec->catfile("t", "tartest", "foo");
-my $tarfile = File::Spec->catfile("t", "tartest.tar");
+my $tartest = File::Spec->catfile("t", "ptargrep");
+my $foo = File::Spec->catfile("t", "ptargrep", "foo");
+my $tarfile = File::Spec->catfile("t", "ptargrep.tar");
my $ptargrep = File::Spec->catfile($Bin, "..", "bin", "ptargrep");
my $cmd = qq/$^X $ptargrep --list-only "file foo" $tarfile/;
# see if ptargrep matches
my $out = qx{$cmd};
-cmp_ok($out, '=~', qr{^t.*tartest.*foo$}m, "ptargrep shows matched file");
+cmp_ok($out, '=~', qr{^t.*ptargrep.*foo$}m, "ptargrep shows matched file");
# cleanup
END {
use strict;
use warnings;
package CPAN::Meta::Requirements;
-our $VERSION = '2.126'; # VERSION
+our $VERSION = '2.128'; # VERSION
# ABSTRACT: a set of version requirements for a CPAN dist
#pod =head1 SYNOPSIS
use Carp ();
use Scalar::Util ();
-use version 0.77 (); # the ->parse method
+
+# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
+# before 5.10, we fall back to the EUMM bundled compatibility version module if
+# that's the only thing available. This shouldn't ever happen in a normal CPAN
+# install of CPAN::Meta::Requirements, as version.pm will be picked up from
+# prereqs and be available at runtime.
+
+BEGIN {
+ eval "use version ()"; ## no critic
+ if ( my $err = $@ ) {
+ eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
+ }
+}
+
+# Perl 5.10.0 didn't have "is_qv" in version.pm
+*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
#pod =method new
#pod
return bless \%self => $class;
}
+# from version::vpp
+sub _find_magic_vstring {
+ my $value = shift;
+ my $tvalue = '';
+ require B;
+ my $sv = B::svref_2object(\$value);
+ my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
+ while ( $magic ) {
+ if ( $magic->TYPE eq 'V' ) {
+ $tvalue = $magic->PTR;
+ $tvalue =~ s/^v?(.+)$/v$1/;
+ last;
+ }
+ else {
+ $magic = $magic->MOREMAGIC;
+ }
+ }
+ return $tvalue;
+}
+
sub _version_object {
my ($self, $version) = @_;
my $vobj;
+ # hack around version::vpp not handling <3 character vstring literals
+ if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) {
+ my $magic = _find_magic_vstring( $version );
+ $version = $magic if length $magic;
+ }
+
eval {
local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" };
- $vobj = (! defined $version) ? version->parse(0)
- : (! Scalar::Util::blessed($version)) ? version->parse($version)
+ $vobj = (! defined $version) ? version->new(0)
+ : (! Scalar::Util::blessed($version)) ? version->new($version)
: $version;
};
# ensure no leading '.'
if ( $vobj =~ m{\A\.} ) {
- $vobj = version->parse("0$vobj");
+ $vobj = version->new("0$vobj");
}
# ensure normal v-string form
- if ( $vobj->is_qv ) {
- $vobj = version->parse($vobj->normal);
+ if ( _is_qv($vobj) ) {
+ $vobj = version->new($vobj->normal);
}
return $vobj;
=head1 VERSION
-version 2.126
+version 2.128
=head1 SYNOPSIS
=head1 CONTRIBUTORS
+=for stopwords Karen Etheridge robario
+
=over 4
=item *
--- /dev/null
+/* Extracted from perl-5.004/universal.c, contributed by Graham Barr */
+
+static SV *
+isa_lookup(stash, name, len, level)
+HV *stash;
+char *name;
+int len;
+int level;
+{
+ AV* av;
+ GV* gv;
+ GV** gvp;
+ HV* hv = Nullhv;
+
+ if (!stash)
+ return &sv_undef;
+
+ if(strEQ(HvNAME(stash), name))
+ return &sv_yes;
+
+ if (level > 100)
+ croak("Recursive inheritance detected");
+
+ gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
+
+ if (gvp && (gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv))) {
+ SV* sv;
+ SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
+ if (svp && (sv = *svp) != (SV*)&sv_undef)
+ return sv;
+ }
+
+ gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
+
+ if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
+ if(!hv) {
+ gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
+
+ gv = *gvp;
+
+ if (SvTYPE(gv) != SVt_PVGV)
+ gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
+
+ hv = GvHVn(gv);
+ }
+ if(hv) {
+ SV** svp = AvARRAY(av);
+ I32 items = AvFILL(av) + 1;
+ while (items--) {
+ SV* sv = *svp++;
+ HV* basestash = gv_stashsv(sv, FALSE);
+ if (!basestash) {
+ if (dowarn)
+ warn("Can't locate package %s for @%s::ISA",
+ SvPVX(sv), HvNAME(stash));
+ continue;
+ }
+ if(&sv_yes == isa_lookup(basestash, name, len, level + 1)) {
+ (void)hv_store(hv,name,len,&sv_yes,0);
+ return &sv_yes;
+ }
+ }
+ (void)hv_store(hv,name,len,&sv_no,0);
+ }
+ }
+
+ return &sv_no;
+}
+
+static bool
+sv_derived_from(sv, name)
+SV * sv ;
+char * name ;
+{
+ SV *rv;
+ char *type;
+ HV *stash;
+
+ stash = Nullhv;
+ type = Nullch;
+
+ if (SvGMAGICAL(sv))
+ mg_get(sv) ;
+
+ if (SvROK(sv)) {
+ sv = SvRV(sv);
+ type = sv_reftype(sv,0);
+ if(SvOBJECT(sv))
+ stash = SvSTASH(sv);
+ }
+ else {
+ stash = gv_stashsv(sv, FALSE);
+ }
+
+ return (type && strEQ(type,name)) ||
+ (stash && isa_lookup(stash, name, strlen(name), 0) == &sv_yes)
+ ? TRUE
+ : FALSE ;
+
+}
+++ /dev/null
-Revision history for ExtUtils-Install
-
-1.63
-
-- Enable tests to run in parallel
-
-1.62
-
-- Various POD fixes and typos
-- Cross-compilation fixes
-- VMS fixes
-
-1.57
-
-Adds 'skip_cwd' parameter to ExtUtils::Installed. With this new parameter,
-the current directory is not included in the installed module search. This
-avoids finding modules from other perls which happen to be below the
-current directory.
-
-1.56
-
-Pod fixes.
-
-1.55
-
-Pod fixes.
-
-1.54
-
-This is a "no-change" version bump because I pushed the v1.53 change
-and then realized that MakeMaker.t was a bad name for a file that would
-end up in core where the EUMM tests and the EUI tests are in the same
-directory. This renames it to InstallWithMM.t.
-
-1.53
-
-Final stage of the divorce from EUMM. Now the EUMM related tests are no
-longer shared. Build.pl and Build.t go, and there shall be peace on earth.
-At least until somebody patches EUMM/t/basic.t for something EUI related...
-
-Thanks to M. Schwern for helping me work this one out. Cheers man.
-
-1.52_03
-
-Missed the t/Installed.t test from core. Bumped version number to allow
-a new distro to be released.
-
-1.52_02
-
-Make _chmod verbose message use octal modes, thanks to BDFOY
-
-Further changes from core, including lastest test file infrastructure
-from EUMM.
-
-Fixed a number of problems in ExtUtils::Installed, for various reasons
-this includes a version bump to 1.999_001, which will eventually become
-version 2.0. These problems related to finding modules that were installed
-with either INSTALL_BASE or PREFIX. Hopefully this resolves these issues.
-
-1.52_01 (core only release)
-
-Changes from Core:
-
-commit 3d55b451d9544fbd4c27c33287b76bee30328830
-Author: John Malmberg
-Date: Sun Feb 15 09:25:10 2009 -0600
-
- ExtUtils::Install VMS extended character set support
-
- Preview from https://rt.cpan.org/Ticket/Display.html?id=42149
-
-
-1.52
-
-Production rerelease of 1.51 to make the CPAN indexer happy about permissions
-(hopefully).
-
-SVN Revision 44.
-
-1.51
-
-Production release of 1.50_05. No other changes.
-
-SVN revision 43.
-
-1.50_05
-
-SVN revision 42.
-
-Fix broken test as reported by Craig Berry.
-
-1.50_04
-
-SVN revision 41.
-
-Restructure tests to make it easier to maintain given it is distributed in various
-ways in three different packages.
-
-1.50_03
-
-SVN revision 40.
-
-Sigh, just after i released 1.50_02 I noticed that a test modified in it will fail
-under VMS. So this is a fixup release for that alone.
-
-1.50_02
-
-SVN revision 39.
-
-Synchronize with the changes that were made in blead perl
-patch #33567. VMS changes by Craig Berry. See
-
-http://perl5.git.perl.org/perl.git/commit/553b5000d7907cb0cb8f4658c1d6a2aac379415b
-
-This was marked in the pod as 1.51 but not actually version bumped.
-
-So I've marked it as 1.50_02 as a test release prior to putting it out
-as the real 1.51
-
-This release also restores the missing installed.t which was accidentally
-missed by the MANIFEST having a duplicate entry for install.t instead.
-Probably something should have warned about this, but I haven't worked out
-what.
-
-Includes changes from Activestate/ActivePerl:
-
-- To make installation less chatty when not under verbose mode. See
-
-http://rt.cpan.org/Public/Bug/Display.html?id=5903
-
-- To install HTML documentation files under builds that set $Config{installhtmldir}
-(and presumably also create HTML versions of the pod -- which is quite nice actually :-)
-
-http://rt.cpan.org/Ticket/Display.html?id=37727
-
-1.50_01
-
-Version only released as part of bleadperl added in revision #33566.
-Cygwin related changes by Steve Hay, and others, see
-
-http://perl5.git.perl.org/perl.git/commit/038ae9a45711aea142f721498a4a61353b40c4e4
-
-and discussion at
-
-http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-03/msg00056.html
-
-1.50
-
-Previous patches to _have_write_access() were causing problems
-on Cygwin. So now we skip using POSIX::access under cygwin.
-Also added some =pod directives to make my favorite editor
-highlight the pod properly.
-
-1.49
-
-Turns out that the new can_write_dir.t doesn't work properly under root
-as root can read the files regardless as to their mode. So we skip those
-tests when the effective UID is 0 indicating root.
-
-1.48
-
-We were getting N/A test results from CPAN testers due to the
-presence of Config in the prequisities list. This has been corrected.
-
-Also it was pointed out that EU_ALWAYS_COPY did not follow the naming
-convention of other ExtUtils::Install environment variables. It has
-been renamed EU_INSTALL_ALWAYS_COPY. Support remains for the original
-deprecated environment variable but it will be removed in 1.50.
-
-1.47
-
-Fix build process so a new META.YML is produced each time. Also
-add support for a new argument syntax to install() as well as
-support for always copying installed files even when the old
-file was identical. This is needed for some bundling mechanisms
-and can be activated by setting the environment variable EU_ALWAYS_COPY
-before the install process starts.
-
-Add a newer cleaner interface to install() to allow named parameters
-and easier external monitoring of what transpired.
-
-1.46 2008-03-01 12:42:35
-
-Apply patches from Michael G. Schwern (rt #33688, rt #31429, rt #31248)
-and from Slaven Rezic (rt #33290). Also implemented the suggestion from
-Schwern about not dieing when failing to remove a shadow file that is
-later on in INC than the installed version. (rt #2928)
-
-1.45 2008-02-27 13:55:27
-
-Fix rt.cpan.org #32813, use catpath() to attach volume name
-to dirs in _can_write_dir() when necessary to avoid cygwin
-builds doing a hostname lookup.
-
-1.44 2007-09-09 23:12:25
-
-by Schwern
-
-*** MAJOR BUG FIX ***
-
-install() would always try to uninstall different versions of the
-installed files when $uninstall_shadows was given whether it was true or false.
-This meant "make install" and "Build install" would both always try to uninstall
-differing versions of the modules. [rt.cpan.org 28672]
-
-1.43 2007-07-21 00:09:24
-
-Turns out some recent version, I haven't figured out which, causes
-ExtUtils::MakeMaker to fail test. The failure is actually bogus, EUMM
-is testing for output that we stopped producing except under verbose,
-however it is a pain, so this release fixes the problem. It also adds
-a new test file, a stripped down version of ExtUtils::MakeMakers
-t/basic.t.
-
-1.42 2007-07-20 22:43:04
-
-This is just 1.41_04 as a production release.
-
-1.41_04 2007-07-07 16:52:40
-
-Reorganize how things work in Install so that we don't try to create
-directories which exist but are not writable to us when they contain
-files which we want to install which are writable by us.
-http://rt.cpan.org/Public/Bug/Display.html?id=25627
-
-Also fix a VMS issue as recommended by Craig Berry.
-http://rt.cpan.org/Public/Bug/Display.html?id=22157
-
-1.41_03 2007-02-11 15:13
-
-Add an extra_libs parameter to ExtUtils::Installed->new() which allows
-one to specify additional libs to search for installed modules.
-
-Additional code cleanup and tweaks.
-
-1.41_02 2007-02-03 21:10
-
-Fix bug in _can_write_file().
-
-1.41_01 2007-02-02 21:03
-
-Integrated changes from
-
-1. Steffen Mueller: make ExtUtils::Installed respect PERL5LIB and allow
-overriding the current config and inc with something else.
-
-2. Michael Schwern (RT#21949, RT#21948): Fix use lib and installdirs
-and other EU::MakeMaker related changes.
-
-3. ActiveState (RT#5903): Reduce install verbosity.
-
-4. Craig Berry (RT#22157): Fix VMS related install failure.
-
-5. Ken Williams (RT#16225): Make fake uninstall actually fake.
-
-
-1.41 2006-07-02 16:09
-
-Integrated ExtUtils::Packlist changes from Nicholas Clark to allow for
-relocatable perls. Bumped version numbers on all files.
-
-1.40 2006-04-30 15:04
-
-Enhanced errorcatching and reporting. Fixed a problem with the INSTALL.SKIP
-file. Changed the Makefile.PL so that when installing it would not use the same
-stuff it was replacing. This doesn't affect building with Module::Build
-currently.
-
-Removed META.yml from distribution.
-
-1.39 2006-04-14 18:53
-
-- Fixed problem with the META.yml file being produced from a Win32 point of view.
-IMO this is an error/failing in the design of the META.yml process. META.yml should
-be created on the client side not on the distributor side. Now produces a
-platform agnostic (ie UNIXy) META.yml.
-
-- Reversed order of change file so newest entries go on top.
-
-
-1.38 2006-04-02 17:31
-
-- Removed MANIFEST.SKIP support (INSTALL.SKIP still supported), and
-added support for providing a fallback skip file by using
-ENV{EU_INSTALL_SITE_SKIP} as a fallback if there is not a distribution
-specific skip file.
-
-- Released under the ExtUtils-Install-1.38 Name
-
-
-1.3702 2006-03-19 16:54
-
-- Added support for skipping files during install based on a set of filter
-rules. If there is an INSTALL.SKIP in the current directory when doing an
-install then it is loaded, otherwise if there is a MANIFEST.SKIP then it is
-loaded. If neither exists then no filtration occurs. The env variable
-EU_INSTALL_IGNORE_SKIP may be set to a true value to override this behaviour.
-This means that you can make .svn directories be ignored on install.
-
-1.3701 2006-03-13 20:00
-
-- Integrated patch from Randy Sims.
-
- 1. Fixes error during 'perl Makefile.PL' because it MakeMaker can't
- find the NAME section describing DISTNAME (which has the 'ex-'
- prefix).
-
- 2. Win32API::File is recommended on MSWin32 && cygwin.
-
- 3. Under Perl5.005, ExtUtils::MM is not present in the version of
- MakeMaker included. I don't know what version first includes it.
- Needs research or better: eliminate need for it.
-
- 4. Test::More is bundled with the distro for its test suite. This
- would be needed on Perl5.005, for example. It was listed as a
- requirement, but the directory it's bundled in is not in @INC when
- prereqs are checked. I removed the prereq from Build.PL &
- Makefile.PL. Other options: 1) fixup @INC to include t/lib; or 2)
- unbundle and add back to prereqs.
-
- 4. Update t/pod.t t/pod-coverage fixup of @INC so it can find
- bundled Test::More.
-
-- Fixed pod/coverage related issues.
-
-- When trying to schedule a delete at reboot after renaming a dll out of
-the way no error occurs if Win32API::File isn't available. Instead it
-merely warns that the file should be hand deleted.
-
-- Fixed install at reboot behaviour by making sure the temporar file is
-writable after install (normally files installed are readonly)
-
-1.37 2006-03-12 23:20
-
-- Refactored reboot support. Integrated changes from Randy Sims
-in p5p message 4413F4E9.7090802@thepierianspring.org
-
-
-1.36 2006-03-11 12:42
-
-- Extended Win32 support. Added ExtUtils::Install::MUST_REBOOT to
-handle such scenario when rebooting.
-
-- Released as ex-ExtUtils-Install by demerphq
-
-1.35 Wed Feb 1 23:00:00 CST 2006
-
- - First independent release; Extracted ExtUtils::Install,
- ExtUtils::Installed, & ExtUtils::Packlist from MakeMaker.
-
- - Changed the $VERSION of all modules to the same version number, a
- number higher than all $VERSIONs.
=head1 VERSION
-1.68
+2.04
=cut
-$VERSION = '1.68'; # <-- do not forget to update the POD section just above this line!
+$VERSION = '2.04'; # <-- do not forget to update the POD section just above this line!
$VERSION = eval $VERSION;
=pod
require VMS::Filespec if $Is_VMS;
use vars qw($VERSION);
-$VERSION = '1.999005';
+$VERSION = '2.04';
$VERSION = eval $VERSION;
sub _is_prefix {
use Carp qw();
use Config;
use vars qw($VERSION $Relocations);
-$VERSION = '1.48';
+$VERSION = '2.04';
$VERSION = eval $VERSION;
# Used for generating filehandle globs. IO::File might not be available!
use strict;
use warnings;
-our $VERSION = '6.98';
+our $VERSION = '6.98_01';
use ExtUtils::MakeMaker::Config;
use Cwd 'cwd';
# For gcc-2.6.2 on linux (March 1995), DLD can not load
# .sa libraries, with the exception of libm.sa, so we
# deliberately skip them.
- if ( @fullname = $self->lsdir( $thispth, "^\Qlib$thislib.$so.\E[0-9]+" ) ) {
-
+ if ((@fullname =
+ $self->lsdir($thispth, "^\Qlib$thislib.$so.\E[0-9]+")) ||
+ (@fullname =
+ $self->lsdir($thispth, "^\Qlib$thislib.\E[0-9]+\Q\.$so"))) {
# Take care that libfoo.so.10 wins against libfoo.so.9.
# Compare two libraries to find the most recent version
# number. E.g. if you have libfoo.so.9.0.7 and
use strict;
use warnings;
-our $VERSION = '1.65';
+our $VERSION = '1.68';
our @ISA = ('Exporter');
our @EXPORT_OK = qw(mkmanifest
manicheck filecheck fullcheck skipcheck
# $File::Find::name is unavailable.
# Also, it's okay to use / here, because MANIFEST files use Unix-style
# paths.
- find({wanted => $wanted},
+ find({wanted => $wanted, follow_fast => 1},
$Is_MacOS ? ":" : ".");
return $found;
# filename may contain spaces if enclosed in ''
# (in which case, \\ and \' are escapes)
- if (($file, $comment) = /^'(\\[\\']|.+)+'\s*(.*)/) {
+ if (($file, $comment) = /^'((?:\\[\\']|.+)+)'\s*(.*)/) {
$file =~ s/\\([\\'])/$1/g;
}
else {
else {
unshift @INC, 't/lib';
}
+ $ENV{PERL_MM_MANIFEST_VERBOSE}=1;
}
chdir 't';
use strict;
-use Test::More tests => 97;
+use Test::More tests => 98;
use Cwd;
use File::Spec;
$Is_VMS_noefs = 0 if $vms_efs;
}
-
# We're going to be chdir'ing and modules are sometimes loaded on the
# fly in this test, so we need an absolute @INC.
@INC = map { File::Spec->rel2abs($_) } @INC;
$funky_files{'space_quote_backslash'} = 'foo bar\\baz\'quux';
}
+# test including a filename which is itself a quoted string
+# https://rt.perl.org/Ticket/Display.html?id=122415
+SKIP: {
+ my $quoted_filename = q{'quoted name.txt'};
+ my $description = "quoted string";
+ add_file( $quoted_filename => $description )
+ or skip "couldn't create $description test file", 1;
+ local $ExtUtils::Manifest::MANIFEST = "albatross";
+ maniadd({ $quoted_filename => $description });
+ is( maniread()->{$quoted_filename}, $description,
+ 'file whose name starts and ends with quotes' );
+ $funky_files{$description} = $quoted_filename;
+}
+
my @funky_keys = qw(space space_quote space_backslash space_quote_backslash);
# test including an external manifest.skip file in MANIFEST.SKIP
{
use strict;
use warnings;
# ABSTRACT: A small, simple, correct HTTP/1.1 client
-our $VERSION = '0.047'; # VERSION
+our $VERSION = '0.049'; # VERSION
use Carp ();
#pod
#pod The C<keep_alive> parameter enables a persistent connection, but only to a
#pod single destination scheme, host and port. Also, if any connection-relevant
-#pod attributes are modified, a persistent connection will be dropped. If you want
-#pod persistent connections across multiple destinations, use multiple HTTP::Tiny
-#pod objects.
+#pod attributes are modified, or if the process ID or thread ID change, the
+#pod persistent connection will be dropped. If you want persistent connections
+#pod across multiple destinations, use multiple HTTP::Tiny objects.
#pod
#pod See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
#pod
use Errno qw[EINTR EPIPE];
use IO::Socket qw[SOCK_STREAM];
+# for thread safety, we need to know thread id or else fake it;
+# requires "threads.pm" to hide it from the minimum version detector
+if ( eval { require "threads.pm"; 1 } ) { ## no critic
+ *_get_tid = sub { threads->tid };
+}
+else {
+ *_get_tid = sub () { 0 };
+}
+
# PERL_HTTP_TINY_IPV4_ONLY is a private environment variable to force old
# behavior if someone is unable to boostrap CPAN from a new perl install; it is
# not intended for general, per-client use and may be removed in the future
$self->{scheme} = $scheme;
$self->{host} = $host;
$self->{port} = $port;
+ $self->{pid} = $$;
+ $self->{tid} = _get_tid();
return $self;
}
sub can_reuse {
my ($self,$scheme,$host,$port) = @_;
return 0 if
- length($self->{rbuf})
+ $self->{pid} != $$
+ || $self->{tid} != _get_tid()
+ || length($self->{rbuf})
|| $scheme ne $self->{scheme}
|| $host ne $self->{host}
|| $port ne $self->{port}
=head1 VERSION
-version 0.047
+version 0.049
=head1 SYNOPSIS
The C<keep_alive> parameter enables a persistent connection, but only to a
single destination scheme, host and port. Also, if any connection-relevant
-attributes are modified, a persistent connection will be dropped. If you want
-persistent connections across multiple destinations, use multiple HTTP::Tiny
-objects.
+attributes are modified, or if the process ID or thread ID change, the
+persistent connection will be dropped. If you want persistent connections
+across multiple destinations, use multiple HTTP::Tiny objects.
See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
=head1 CONTRIBUTORS
+=for stopwords Alan Gardner James Raspass Jess Robinson Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Petr Písař Serguei Trouchelle Syohei YOSHIDA Sören Kornetzki Alessandro Ghedini Tom Hukins Tony Cook Brad Gilbert Chris Nehren Weyl Claes Jakobsson Clinton Gormley Craig Berry David Mitchell Edward Zborowski
+
=over 4
=item *
=item *
-Alessandro Ghedini <al3xbio@gmail.com>
+James Raspass <jraspass@gmail.com>
=item *
-Brad Gilbert <bgills@cpan.org>
+Jess Robinson <castaway@desert-island.me.uk>
=item *
-Chris Nehren <apeiron@cpan.org>
+Lukas Eklund <leklund@gmail.com>
=item *
-Chris Weyl <rsrchboy@cpan.org>
+Martin J. Evans <mjegh@ntlworld.com>
=item *
-Claes Jakobsson <claes@surfar.nu>
+Martin-Louis Bright <mlbright@gmail.com>
=item *
-Clinton Gormley <clint@traveljury.com>
+Mike Doherty <doherty@cpan.org>
=item *
-Craig Berry <cberry@cpan.org>
+Petr Písař <ppisar@redhat.com>
=item *
-David Mitchell <davem@iabyn.com>
+Serguei Trouchelle <stro@cpan.org>
=item *
-Edward Zborowski <ed@rubensteintech.com>
+Syohei YOSHIDA <syohex@gmail.com>
=item *
-James Raspass <jraspass@gmail.com>
+Sören Kornetzki <soeren.kornetzki@delti.com>
=item *
-Jess Robinson <castaway@desert-island.me.uk>
+Alessandro Ghedini <al3xbio@gmail.com>
=item *
-Lukas Eklund <leklund@gmail.com>
+Tom Hukins <tom@eborcom.com>
=item *
-Martin J. Evans <mjegh@ntlworld.com>
+Tony Cook <tony@develop-help.com>
=item *
-Martin-Louis Bright <mlbright@gmail.com>
+Brad Gilbert <bgills@cpan.org>
=item *
-Mike Doherty <doherty@cpan.org>
+Chris Nehren <apeiron@cpan.org>
=item *
-Petr Písař <ppisar@redhat.com>
+Chris Weyl <rsrchboy@cpan.org>
=item *
-Serguei Trouchelle <stro@cpan.org>
+Claes Jakobsson <claes@surfar.nu>
=item *
-Syohei YOSHIDA <syohex@gmail.com>
+Clinton Gormley <clint@traveljury.com>
=item *
-Sören Kornetzki <soeren.kornetzki@delti.com>
+Craig Berry <cberry@cpan.org>
=item *
-Tony Cook <tony@develop-help.com>
+David Mitchell <davem@iabyn.com>
+
+=item *
+
+Edward Zborowski <ed@rubensteintech.com>
=back
# Require a true value
for my $proxy (undef, "", 0){
+ local $ENV{all_proxy} = undef;
+ local $ENV{ALL_PROXY} = undef;
local $ENV{http_proxy} = $proxy;
my $c = HTTP::Tiny->new();
ok(!defined $c->http_proxy);
$self->{port} = $monkey_port = $port;
$self->{scheme} = $scheme;
$self->{fh} = shift @req_fh;
+ $self->{pid} = $$;
+ $self->{tid} = HTTP::Tiny::Handle::_get_tid();
return $self;
};
my $original_write_request = \&HTTP::Tiny::Handle::write_request;
# $VERSION needs to be set before use base 'IO::Socket'
# - https://rt.cpan.org/Ticket/Display.html?id=92107
BEGIN {
- $VERSION = '0.31';
+ $VERSION = '0.32';
}
use strict;
my $AF_INET6 = eval { Socket::AF_INET6() }; # may not be defined
my $AI_ADDRCONFIG = eval { Socket::AI_ADDRCONFIG() } || 0;
use POSIX qw( dup2 );
-use Errno qw( EINVAL EINPROGRESS EISCONN );
+use Errno qw( EINVAL EINPROGRESS EISCONN ETIMEDOUT EWOULDBLOCK );
use constant HAVE_MSWIN32 => ( $^O eq "MSWin32" );
it will default to blocking mode. See the NON-BLOCKING section below for more
detail.
+=item Timeout => NUM
+
+If defined, gives a maximum time in seconds to block per C<connect()> call
+when in blocking mode. If missing, no timeout is applied other than that
+provided by the underlying operating system. When in non-blocking mode this
+parameter is ignored.
+
+Note that if the hostname resolves to multiple address candidates, the same
+timeout will apply to each connection attempt individually, rather than to the
+operation as a whole. Further note that the timeout does not apply to the
+initial hostname resolve operation, if connecting by hostname.
+
+This behviour is copied inspired by C<IO::Socket::INET>; for more fine grained
+control over connection timeouts, consider performing a nonblocking connect
+directly.
+
=back
If neither C<Type> nor C<Proto> hints are provided, a default of
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 ! $!;
+ # 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;
# useful APIs I'm just going to end-run around it and call CORE::connect()
# directly
- return CORE::connect( $self, $_[0] ) if @_;
+ if( @_ ) {
+ my ( $addr ) = @_;
+
+ # Annoyingly IO::Socket's connect() is where the timeout logic is
+ # implemented, so we'll have to reinvent it here
+ my $timeout = ${*$self}{'io_socket_timeout'};
+
+ return CORE::connect( $self, $addr ) unless defined $timeout;
+
+ my $was_blocking = $self->blocking( 0 );
+
+ my $err = defined CORE::connect( $self, $addr ) ? 0 : $!+0;
+
+ if( !$err ) {
+ # All happy
+ return 1;
+ }
+ elsif( not( $err == EINPROGRESS or $err == EWOULDBLOCK ) ) {
+ # Failed for some other reason
+ return undef;
+ }
+ elsif( !$was_blocking ) {
+ # We shouldn't block anyway
+ return undef;
+ }
+
+ my $vec = ''; vec( $vec, $self->fileno, 1 ) = 1;
+ if( !select( $vec, $vec, $vec, $timeout ) ) {
+ $! = ETIMEDOUT;
+ return undef;
+ }
+
+ # Hoist the error by connect()ing a second time
+ $err = defined CORE::connect( $self, $addr ) ? 0 : $!+0;
+ $err = 0 if $err == EISCONN; # Some OSes give EISCONN
+
+ $self->blocking( $was_blocking );
+
+ $! = $err, return undef if $err;
+ return 1;
+ }
return 1 if !${*$self}{io_socket_ip_connect_in_progress};
but false. An exception is thrown in this case, because that would request it
disable the C<getaddrinfo(3)> search behaviour in the first place.
+=item *
+
+C<IO::Socket::IP> implements both the C<Blocking> and C<Timeout> parameters,
+but it implements the interaction of both in a different way.
+
+In C<::INET>, supplying a timeout overrides the non-blocking behaviour,
+meaning that the C<connect()> operation will still block despite that the
+caller asked for a non-blocking socket. This is not explicitly specified in
+its documentation, nor does this author believe that is a useful behaviour -
+it appears to come from a quirk of implementation.
+
+In C<::IP> therefore, the C<Blocking> parameter takes precedence - if a
+non-blocking socket is requested, no operation will block. The C<Timeout>
+parameter here simply defines the maximum time that a blocking C<connect()>
+call will wait, if it blocks at all.
+
+In order to specifically obtain the "blocking connect then non-blocking send
+and receive" behaviour of specifying this combination of options to C<::INET>
+when using C<::IP>, perform first a blocking connect, then afterwards turn the
+socket into nonblocking mode.
+
+ my $sock = IO::Socket::IP->new(
+ PeerHost => $peer,
+ Timeout => 20,
+ ) or die "Cannot connect - $@";
+
+ $sock->blocking( 0 );
+
+This code will behave identically under both C<IO::Socket::INET> and
+C<IO::Socket::IP>.
+
=back
=cut
my $testserver = IO::Socket::IP->new(
( $socktype eq "SOCK_STREAM" ? ( Listen => 1 ) : () ),
LocalHost => "127.0.0.1",
+ Port => 0,
Type => Socket->$socktype,
);
my $testserver = IO::Socket::IP->new(
( $socktype eq "SOCK_STREAM" ? ( Listen => 1 ) : () ),
LocalHost => "127.0.0.1",
+ Port => 0,
Type => Socket->$socktype,
) or die "Cannot listen on PF_INET - $@";
my $testserver = IO::Socket::IP->new(
( $socktype eq "SOCK_STREAM" ? ( Listen => 1 ) : () ),
LocalHost => "::1",
+ Port => 0,
Type => Socket->$socktype,
GetAddrInfoFlags => 0, # disable AI_ADDRCONFIG
);
my $testserver = IO::Socket::IP->new(
( $socktype eq "SOCK_STREAM" ? ( Listen => 1 ) : () ),
LocalHost => "::1",
+ Port => 0,
Type => Socket->$socktype,
) or die "Cannot listen on PF_INET6 - $@";
Type => SOCK_STREAM,
LocalHost => "127.0.0.1",
LocalPort => 0,
+ GetAddrInfoFlags => 0, # disable AI_ADDRCONFIG
);
isa_ok( $sock, "IO::Socket::IP", 'IO::Socket->new( Domain => AF_INET )' ) or
Type => SOCK_STREAM,
LocalHost => "::1",
LocalPort => 0,
+ GetAddrInfoFlags => 0, # disable AI_ADDRCONFIG
);
isa_ok( $sock, "IO::Socket::IP", 'IO::Socket->new( Domain => AF_INET6 )' ) or
LocalPort => 0,
Type => SOCK_STREAM,
V6Only => 1,
+ GetAddrInfoFlags => 0, # disable AI_ADDRCONFIG
) or die "Cannot listen on PF_INET6 - $@";
is( $listensock->getsockopt( IPPROTO_IPV6, IPV6_V6ONLY ), 1, 'IPV6_V6ONLY is 1 on $listensock' );
PeerHost => "127.0.0.1",
PeerPort => $listensock->sockport,
Type => SOCK_STREAM,
+ GetAddrInfoFlags => 0, # disable AI_ADDRCONFIG
);
my $err = "$@";
LocalPort => 0,
Type => SOCK_STREAM,
V6Only => 0,
+ GetAddrInfoFlags => 0, # disable AI_ADDRCONFIG
) or die "Cannot listen on PF_INET6 - $@";
is( $listensock->getsockopt( IPPROTO_IPV6, IPV6_V6ONLY ), 0, 'IPV6_V6ONLY is 0 on $listensock' );
PeerHost => "127.0.0.1",
PeerPort => $listensock->sockport,
Type => SOCK_STREAM,
+ GetAddrInfoFlags => 0, # disable AI_ADDRCONFIG
);
my $err = "$@";
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use IO::Socket::IP;
+
+my $server = IO::Socket::IP->new(
+ Listen => 1,
+ LocalHost => "127.0.0.1",
+ LocalPort => 0,
+) or die "Cannot listen on PF_INET - $!";
+
+my $client = IO::Socket::IP->new(
+ PeerHost => $server->sockhost,
+ PeerPort => $server->sockport,
+ Timeout => 0.1,
+) or die "Cannot connect on PF_INET - $!";
+
+ok( defined $client, 'client constructed with Timeout' );
+
+my $accepted = $server->accept
+ or die "Cannot accept - $!";
+
+ok( defined $accepted, 'accepted a client' );
+
+done_testing;
# $Retired{ TYPE }{ CODESET }{ code }{ CODE } = NAME
# { name }{ NAME } = [CODE,NAME] (the key is lowercase)
-$VERSION='3.31';
+$VERSION='3.32';
#=======================================================================
#
=head1 VERSION 3.33 (planned 2014-12-01; sbeck)
-=head1 VERSION 3.32 (planned 2014-09-01; sbeck)
+=head1 VERSION 3.32 (2014-09-01; sbeck)
+
+NEW CODE(s)
=head1 VERSION 3.31 (2014-06-01; sbeck)
our($VERSION,@ISA,@EXPORT);
our(%ALL_CODESETS);
-$VERSION='3.31';
+$VERSION='3.32';
@ISA = qw(Exporter);
@EXPORT = qw(LOCALE_CODE_ALPHA_2
LOCALE_CODE_ALPHA_3
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.31';
+$VERSION='3.32';
@ISA = qw(Exporter);
@EXPORT = qw(code2country
country2code
=over 4
-=item B<code2country ( CODE [,CODESET] )>
+=item B<code2country ( CODE [,CODESET] [,'retired'])>
-=item B<country2code ( NAME [,CODESET] )>
+=item B<country2code ( NAME [,CODESET] [,'retired'])>
=item B<country_code2code ( CODE ,CODESET ,CODESET2 )>
-=item B<all_country_codes ( [CODESET] )>
+=item B<all_country_codes ( [CODESET] [,'retired'])>
-=item B<all_country_names ( [CODESET] )>
+=item B<all_country_names ( [CODESET] [,'retired'])>
=item B<Locale::Codes::Country::rename_country ( CODE ,NEW_NAME [,CODESET] )>
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Wed May 28 10:41:20 EDT 2014
+# Generated on: Fri Aug 22 15:26:47 EDT 2014
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.31';
+$VERSION='3.32';
$Locale::Codes::Data{'country'}{'id'} = '0250';
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Wed May 28 11:24:54 EDT 2014
+# Generated on: Tue Aug 26 11:38:09 EDT 2014
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.31';
+$VERSION='3.32';
$Locale::Codes::Retired{'country'}{'alpha-2'}{'code'} = {
q(an) => q(Netherlands Antilles),
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.31';
+$VERSION='3.32';
@ISA = qw(Exporter);
@EXPORT = qw(code2currency
currency2code
=over 4
-=item B<code2currency ( CODE [,CODESET] )>
+=item B<code2currency ( CODE [,CODESET] [,'retired'])>
-=item B<currency2code ( NAME [,CODESET] )>
+=item B<currency2code ( NAME [,CODESET] [,'retired'])>
=item B<currency_code2code ( CODE ,CODESET ,CODESET2 )>
-=item B<all_currency_codes ( [CODESET] )>
+=item B<all_currency_codes ( [CODESET] [,'retired'])>
-=item B<all_currency_names ( [CODESET] )>
+=item B<all_currency_names ( [CODESET] [,'retired'])>
=item B<Locale::Codes::Currency::rename_currency ( CODE ,NEW_NAME [,CODESET] )>
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Wed May 28 11:22:06 EDT 2014
+# Generated on: Fri Aug 22 15:31:17 EDT 2014
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.31';
+$VERSION='3.32';
$Locale::Codes::Data{'currency'}{'id'} = '0178';
q(Canadian Dollar),
],
q(0035) => [
- q(Cape Verde Escudo),
+ q(Cabo Verde Escudo),
],
q(0036) => [
q(Cayman Islands Dollar),
q(0031),
q(0),
],
- q(canadian dollar) => [
- q(0034),
+ q(cabo verde escudo) => [
+ q(0035),
q(0),
],
- q(cape verde escudo) => [
- q(0035),
+ q(canadian dollar) => [
+ q(0034),
q(0),
],
q(cayman islands dollar) => [
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Wed May 28 11:24:54 EDT 2014
+# Generated on: Tue Aug 26 11:38:09 EDT 2014
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.31';
+$VERSION='3.32';
$Locale::Codes::Retired{'currency'}{'alpha'}{'code'} = {
q(ADP) => q(Andorran Peseta),
q(bolivar fuerte) => [ q(VEF), q(Bolivar Fuerte) ],
q(bond markets units european composite unit (eurco)) => [ q(XBA), q(Bond Markets Units European Composite Unit (EURCO)) ],
q(candian dollar) => [ q(CAD), q(Candian Dollar) ],
+ q(cape verde escudo) => [ q(CVE), q(Cape Verde Escudo) ],
q(cedi) => [ q(GHS), q(Cedi) ],
q(convertible marks) => [ q(BAM), q(Convertible Marks) ],
q(cyprus pound) => [ q(CYP), q(Cyprus Pound) ],
$Locale::Codes::Retired{'currency'}{'num'}{'name'} = {
q(bolivar fuerte) => [ q(937), q(Bolivar Fuerte) ],
+ q(cape verde escudo) => [ q(132), q(Cape Verde Escudo) ],
q(cedi) => [ q(936), q(Cedi) ],
q(latvian lats) => [ q(428), q(Latvian Lats) ],
q(leu) => [ q(946), q(Leu) ],
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.31';
+$VERSION='3.32';
@ISA = qw(Exporter);
@EXPORT = qw(code2langext
langext2code
=over 4
-=item B<code2langext ( CODE [,CODESET] )>
+=item B<code2langext ( CODE [,CODESET] [,'retired'])>
-=item B<langext2code ( NAME [,CODESET] )>
+=item B<langext2code ( NAME [,CODESET] [,'retired'])>
=item B<langext_code2code ( CODE ,CODESET ,CODESET2 )>
-=item B<all_langext_codes ( [CODESET] )>
+=item B<all_langext_codes ( [CODESET] [,'retired'])>
-=item B<all_langext_names ( [CODESET] )>
+=item B<all_langext_names ( [CODESET] [,'retired'])>
=item B<Locale::Codes::LangExt::rename_langext ( CODE ,NEW_NAME [,CODESET] )>
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Wed May 28 11:23:46 EDT 2014
+# Generated on: Fri Aug 22 15:31:59 EDT 2014
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.31';
+$VERSION='3.32';
$Locale::Codes::Data{'langext'}{'id'} = '0229';
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Wed May 28 11:24:54 EDT 2014
+# Generated on: Tue Aug 26 11:38:09 EDT 2014
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.31';
+$VERSION='3.32';
$Locale::Codes::Retired{'langext'}{'alpha'}{'code'} = {
};
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.31';
+$VERSION='3.32';
@ISA = qw(Exporter);
@EXPORT = qw(code2langfam
langfam2code
=over 4
-=item B<code2langfam ( CODE [,CODESET] )>
+=item B<code2langfam ( CODE [,CODESET] [,'retired'])>
-=item B<langfam2code ( NAME [,CODESET] )>
+=item B<langfam2code ( NAME [,CODESET] [,'retired'])>
=item B<langfam_code2code ( CODE ,CODESET ,CODESET2 )>
-=item B<all_langfam_codes ( [CODESET] )>
+=item B<all_langfam_codes ( [CODESET] [,'retired'])>
-=item B<all_langfam_names ( [CODESET] )>
+=item B<all_langfam_names ( [CODESET] [,'retired'])>
=item B<Locale::Codes::LangFam::rename_langfam ( CODE ,NEW_NAME [,CODESET] )>
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Wed May 28 11:23:56 EDT 2014
+# Generated on: Fri Aug 22 15:32:07 EDT 2014
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.31';
+$VERSION='3.32';
$Locale::Codes::Data{'langfam'}{'id'} = '0116';
require 5.002;
our($VERSION);
-$VERSION='3.31';
+$VERSION='3.32';
$Locale::Codes::Retired{'langfam'}{'alpha'}{'code'} = {
};
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.31';
+$VERSION='3.32';
@ISA = qw(Exporter);
@EXPORT = qw(code2langvar
langvar2code
=over 4
-=item B<code2langvar ( CODE [,CODESET] )>
+=item B<code2langvar ( CODE [,CODESET] [,'retired'])>
-=item B<langvar2code ( NAME [,CODESET] )>
+=item B<langvar2code ( NAME [,CODESET] [,'retired'])>
=item B<langvar_code2code ( CODE ,CODESET ,CODESET2 )>
-=item B<all_langvar_codes ( [CODESET] )>
+=item B<all_langvar_codes ( [CODESET] [,'retired'])>
-=item B<all_langvar_names ( [CODESET] )>
+=item B<all_langvar_names ( [CODESET] [,'retired'])>
=item B<Locale::Codes::LangVar::rename_langvar ( CODE ,NEW_NAME [,CODESET] )>
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Wed May 28 11:23:53 EDT 2014
+# Generated on: Fri Aug 22 15:32:06 EDT 2014
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.31';
+$VERSION='3.32';
$Locale::Codes::Data{'langvar'}{'id'} = '0067';
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Wed May 28 11:24:54 EDT 2014
+# Generated on: Tue Aug 26 11:38:09 EDT 2014
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.31';
+$VERSION='3.32';
$Locale::Codes::Retired{'langvar'}{'alpha'}{'code'} = {
};
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.31';
+$VERSION='3.32';
@ISA = qw(Exporter);
@EXPORT = qw(code2language
language2code
=over 4
-=item B<code2language ( CODE [,CODESET] )>
+=item B<code2language ( CODE [,CODESET] [,'retired'])>
-=item B<language2code ( NAME [,CODESET] )>
+=item B<language2code ( NAME [,CODESET] [,'retired'])>
=item B<language_code2code ( CODE ,CODESET ,CODESET2 )>
-=item B<all_language_codes ( [CODESET] )>
+=item B<all_language_codes ( [CODESET] [,'retired'])>
-=item B<all_language_names ( [CODESET] )>
+=item B<all_language_names ( [CODESET] [,'retired'])>
=item B<Locale::Codes::Language::rename_language ( CODE ,NEW_NAME [,CODESET] )>
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Wed May 28 10:48:07 EDT 2014
+# Generated on: Fri Aug 22 15:27:10 EDT 2014
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.31';
+$VERSION='3.32';
$Locale::Codes::Data{'language'}{'id'} = '7991';
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Wed May 28 11:24:54 EDT 2014
+# Generated on: Tue Aug 26 11:38:09 EDT 2014
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.31';
+$VERSION='3.32';
$Locale::Codes::Retired{'language'}{'alpha-2'}{'code'} = {
q(in) => q(Indonesian),
our($VERSION,@ISA,@EXPORT,@EXPORT_OK);
-$VERSION='3.31';
+$VERSION='3.32';
@ISA = qw(Exporter);
@EXPORT = qw(code2script
script2code
=over 4
-=item B<code2script ( CODE [,CODESET] )>
+=item B<code2script ( CODE [,CODESET] [,'retired'])>
-=item B<script2code ( NAME [,CODESET] )>
+=item B<script2code ( NAME [,CODESET] [,'retired'])>
=item B<script_code2code ( CODE ,CODESET ,CODESET2 )>
-=item B<all_script_codes ( [CODESET] )>
+=item B<all_script_codes ( [CODESET] [,'retired'])>
-=item B<all_script_names ( [CODESET] )>
+=item B<all_script_names ( [CODESET] [,'retired'])>
=item B<Locale::Codes::Script::rename_script ( CODE ,NEW_NAME [,CODESET] )>
# This file was automatically generated. Any changes to this file will
# be lost the next time 'harvest_data' is run.
-# Generated on: Wed May 28 11:22:35 EDT 2014
+# Generated on: Fri Aug 22 15:31:57 EDT 2014
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.31';
+$VERSION='3.32';
$Locale::Codes::Data{'script'}{'id'} = '0166';
# This file was automatically generated. Any changes to this file will
# be lost the next time 'deprecate_codes' is run.
-# Generated on: Wed May 28 11:24:54 EDT 2014
+# Generated on: Tue Aug 26 11:38:09 EDT 2014
use strict;
require 5.006;
use utf8;
our($VERSION);
-$VERSION='3.31';
+$VERSION='3.32';
$Locale::Codes::Retired{'script'}{'alpha'}{'code'} = {
};
use Exporter;
our $VERSION;
-$VERSION='3.31';
+$VERSION='3.32';
our (@ISA,@EXPORT);
=over 4
-=item B<code2country ( CODE [,CODESET] )>
+=item B<code2country ( CODE [,CODESET] [,'retired'])>
-=item B<country2code ( NAME [,CODESET] )>
+=item B<country2code ( NAME [,CODESET] [,'retired'])>
=item B<country_code2code ( CODE ,CODESET ,CODESET2 )>
-=item B<all_country_codes ( [CODESET] )>
+=item B<all_country_codes ( [CODESET] [,'retired'])>
-=item B<all_country_names ( [CODESET] )>
+=item B<all_country_names ( [CODESET] [,'retired'])>
=item B<Locale::Country::rename_country ( CODE ,NEW_NAME [,CODESET] )>
use Exporter;
our $VERSION;
-$VERSION='3.31';
+$VERSION='3.32';
our (@ISA,@EXPORT);
=over 4
-=item B<code2currency ( CODE [,CODESET] )>
+=item B<code2currency ( CODE [,CODESET] [,'retired'])>
-=item B<currency2code ( NAME [,CODESET] )>
+=item B<currency2code ( NAME [,CODESET] [,'retired'])>
=item B<currency_code2code ( CODE ,CODESET ,CODESET2 )>
-=item B<all_currency_codes ( [CODESET] )>
+=item B<all_currency_codes ( [CODESET] [,'retired'])>
-=item B<all_currency_names ( [CODESET] )>
+=item B<all_currency_names ( [CODESET] [,'retired'])>
=item B<Locale::Currency::rename_currency ( CODE ,NEW_NAME [,CODESET] )>
use Exporter;
our $VERSION;
-$VERSION='3.31';
+$VERSION='3.32';
our (@ISA,@EXPORT);
=over 4
-=item B<code2language ( CODE [,CODESET] )>
+=item B<code2language ( CODE [,CODESET] [,'retired'])>
-=item B<language2code ( NAME [,CODESET] )>
+=item B<language2code ( NAME [,CODESET] [,'retired'])>
=item B<language_code2code ( CODE ,CODESET ,CODESET2 )>
-=item B<all_language_codes ( [CODESET] )>
+=item B<all_language_codes ( [CODESET] [,'retired'])>
-=item B<all_language_names ( [CODESET] )>
+=item B<all_language_names ( [CODESET] [,'retired'])>
=item B<Locale::Language::rename_language ( CODE ,NEW_NAME [,CODESET] )>
use Exporter;
our $VERSION;
-$VERSION='3.31';
+$VERSION='3.32';
our (@ISA,@EXPORT);
=over 4
-=item B<code2script ( CODE [,CODESET] )>
+=item B<code2script ( CODE [,CODESET] [,'retired'])>
-=item B<script2code ( NAME [,CODESET] )>
+=item B<script2code ( NAME [,CODESET] [,'retired'])>
=item B<script_code2code ( CODE ,CODESET ,CODESET2 )>
-=item B<all_script_codes ( [CODESET] )>
+=item B<all_script_codes ( [CODESET] [,'retired'])>
-=item B<all_script_names ( [CODESET] )>
+=item B<all_script_names ( [CODESET] [,'retired'])>
=item B<Locale::Script::rename_script ( CODE ,NEW_NAME [,CODESET] )>
use vars qw($VERSION @Pagers $Bindir $Pod2man
$Temp_Files_Created $Temp_File_Lifetime
);
-$VERSION = '3.23';
+$VERSION = '3.24';
#..........................................................................
$self->aside("Hm, I found some Pod from that search!\n");
my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
if ( $] >= 5.008 && $self->opt_L ) {
- binmode($buffd, ":utf8");
+ binmode($buffd, ":encoding(UTF-8)");
print $buffd "=encoding utf8\n\n";
}
open(PVAR, "<", $perlvar) # "Funk is its own reward"
or $self->die("Can't open $perlvar: $!");
+ binmode(PVAR, ":encoding(UTF-8)");
if ( $opt ne '$0' && $opt =~ /^\$\d+$/ ) { # handle $1, $2, ...
$opt = '$<I<digits>>';
}
# especially since we need to support UTF8 or other encoding when dealing
# with perlop, perlfunc, perlapi, perlfaq[1-9]
open( PERLOP, '<', $perlop ) or $self->die( "Can't open $perlop: $!" );
+ binmode(PERLOP, ":encoding(UTF-8)");
my $thing = $self->opt_f;
$self->aside("Your old perl doesn't really have proper unicode support.");
}
else {
- binmode(PAPI, ":utf8");
+ binmode(PAPI, ":encoding(UTF-8)");
}
}
$self->aside("Your old perl doesn't really have proper unicode support.");
}
else {
- binmode(PFUNC, ":utf8");
+ binmode(PFUNC, ":encoding(UTF-8)");
}
}
$self->die( "invalid file spec: $!" ) if $file =~ /[<>|]/;
open(INFAQ, "<", $file) # XXX 5.6ism
or $self->die( "Can't read-open $file: $!\nAborting" );
+ binmode(INFAQ, ":encoding(UTF-8)");
while (<INFAQ>) {
if ( m/^=head2\s+.*(?:$search_key)/i ) {
$found = 1;
use warnings;
use vars qw($VERSION);
-$VERSION = '3.23';
+$VERSION = '3.24';
use Carp qw(croak carp);
use Config qw(%Config);
use strict;
use vars qw($VERSION);
-$VERSION = '3.23';
+$VERSION = '3.24';
BEGIN { # Make a DEBUG constant ASAP
*DEBUG = defined( &Pod::Perldoc::DEBUG )
use parent qw(Pod::Perldoc::BaseTo);
use vars qw($VERSION);
-$VERSION = '3.23';
+$VERSION = '3.24';
sub is_pageable { 1 }
sub write_with_binmode { 0 }
use vars qw(@ISA);
use vars qw($VERSION);
-$VERSION = '3.23';
+$VERSION = '3.24';
# Pick our superclass...
#
use parent qw(Pod::Perldoc::BaseTo);
use vars qw($VERSION);
-$VERSION = '3.23';
+$VERSION = '3.24';
use File::Spec::Functions qw(catfile);
use Pod::Man 2.18;
use parent qw(Pod::Perldoc::BaseTo);
use vars qw($VERSION);
-$VERSION = '3.23';
+$VERSION = '3.24';
# This is unlike ToMan.pm in that it emits the raw nroff source!
use parent qw(Pod::Perldoc::BaseTo);
use vars qw($VERSION);
-$VERSION = '3.23';
+$VERSION = '3.24';
sub is_pageable { 1 }
sub write_with_binmode { 0 }
use parent qw( Pod::Simple::RTF );
use vars qw($VERSION);
-$VERSION = '3.23';
+$VERSION = '3.24';
sub is_pageable { 0 }
sub write_with_binmode { 0 }
use warnings;
use vars qw($VERSION);
-$VERSION = '3.23';
+$VERSION = '3.24';
use parent qw(Pod::Perldoc::BaseTo);
use warnings;
use vars qw($VERSION);
-$VERSION = '3.23';
+$VERSION = '3.24';
use parent qw(Pod::Perldoc::BaseTo);
use warnings;
use vars qw($VERSION);
-$VERSION = '3.23';
+$VERSION = '3.24';
use parent qw(Pod::Perldoc::BaseTo);
use parent qw( Pod::Simple::XMLOutStream );
use vars qw($VERSION);
-$VERSION = '3.23';
+$VERSION = '3.24';
sub is_pageable { 0 }
sub write_with_binmode { 0 }
return ACC_NV;
}
+/* Magic for set_subname */
+static MGVTBL subname_vtbl;
+
MODULE=List::Util PACKAGE=List::Util
void
retsv = TARG;
switch(accum) {
+ case ACC_SV: /* nothing to do */
+ break;
case ACC_IV:
sv_setiv(retsv, retiv);
break;
SAVESPTR(GvSV(agv));
SAVESPTR(GvSV(bgv));
GvSV(agv) = ret;
- SvSetSV(ret, args[1]);
+ SvSetMagicSV(ret, args[1]);
#ifdef dMULTICALL
if(!CvISXSUB(cv)) {
dMULTICALL;
for(index = 2 ; index < items ; index++) {
GvSV(bgv) = args[index];
MULTICALL;
- SvSetSV(ret, *PL_stack_sp);
+ SvSetMagicSV(ret, *PL_stack_sp);
}
# ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT
if(CvDEPTH(multicall_cv) > 1)
PUSHMARK(SP);
call_sv((SV*)cv, G_SCALAR);
- SvSetSV(ret, *PL_stack_sp);
+ SvSetMagicSV(ret, *PL_stack_sp);
}
}
croak("vstrings are not implemented in this release of perl");
#endif
-int
+SV *
looks_like_number(sv)
SV *sv
PROTOTYPE: $
}
#if PERL_BCDVERSION < 0x5008005
if(SvPOK(sv) || SvPOKp(sv)) {
- RETVAL = !!looks_like_number(sv);
+ RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no;
}
else {
- RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
+ RETVAL = (SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK)) ? &PL_sv_yes : &PL_sv_no;
}
#else
- RETVAL = !!looks_like_number(sv);
+ RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no;
#endif
OUTPUT:
RETVAL
void
-set_prototype(subref, proto)
- SV *subref
- SV *proto
-PROTOTYPE: &$
-CODE:
-{
- SvGETMAGIC(subref);
- if(SvROK(subref)) {
- SV *sv = SvRV(subref);
- if(SvTYPE(sv) != SVt_PVCV) {
- /* not a subroutine reference */
- croak("set_prototype: not a subroutine reference");
- }
- if(SvPOK(proto)) {
- /* set the prototype */
- sv_copypv(sv, proto);
- }
- else {
- /* delete the prototype */
- SvPOK_off(sv);
- }
- }
- else {
- croak("set_prototype: not a reference");
- }
- XSRETURN(1);
-}
-
-void
openhandle(SV *sv)
PROTOTYPE: $
CODE:
XSRETURN_UNDEF;
}
+MODULE=List::Util PACKAGE=Sub::Util
+
+void
+set_prototype(proto, code)
+ SV *proto
+ SV *code
+PREINIT:
+ SV *cv; /* not CV * */
+PPCODE:
+ SvGETMAGIC(code);
+ if(!SvROK(code))
+ croak("set_prototype: not a reference");
+
+ cv = SvRV(code);
+ if(SvTYPE(cv) != SVt_PVCV)
+ croak("set_prototype: not a subroutine reference");
+
+ if(SvPOK(proto)) {
+ /* set the prototype */
+ sv_copypv(cv, proto);
+ }
+ else {
+ /* delete the prototype */
+ SvPOK_off(cv);
+ }
+
+ PUSHs(code);
+ XSRETURN(1);
+
+void
+set_subname(name, sub)
+ char *name
+ SV *sub
+PREINIT:
+ CV *cv = NULL;
+ GV *gv;
+ HV *stash = CopSTASH(PL_curcop);
+ char *s, *end = NULL;
+ MAGIC *mg;
+PPCODE:
+ if (!SvROK(sub) && SvGMAGICAL(sub))
+ mg_get(sub);
+ if (SvROK(sub))
+ cv = (CV *) SvRV(sub);
+ else if (SvTYPE(sub) == SVt_PVGV)
+ cv = GvCVu(sub);
+ else if (!SvOK(sub))
+ croak(PL_no_usym, "a subroutine");
+ else if (PL_op->op_private & HINT_STRICT_REFS)
+ croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
+ SvPV_nolen(sub), "a subroutine");
+ else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
+ cv = GvCVu(gv);
+ if (!cv)
+ croak("Undefined subroutine %s", SvPV_nolen(sub));
+ if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
+ croak("Not a subroutine reference");
+ for (s = name; *s++; ) {
+ if (*s == ':' && s[-1] == ':')
+ end = ++s;
+ else if (*s && s[-1] == '\'')
+ end = s;
+ }
+ s--;
+ if (end) {
+ char *namepv = savepvn(name, end - name);
+ stash = GvHV(gv_fetchpv(namepv, TRUE, SVt_PVHV));
+ Safefree(namepv);
+ name = end;
+ }
+
+ /* under debugger, provide information about sub location */
+ if (PL_DBsub && CvGV(cv)) {
+ HV *hv = GvHV(PL_DBsub);
+
+ char *new_pkg = HvNAME(stash);
+
+ char *old_name = GvNAME( CvGV(cv) );
+ char *old_pkg = HvNAME( GvSTASH(CvGV(cv)) );
+
+ int old_len = strlen(old_name) + strlen(old_pkg);
+ int new_len = strlen(name) + strlen(new_pkg);
+
+ SV **old_data;
+ char *full_name;
+
+ Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char);
+
+ strcat(full_name, old_pkg);
+ strcat(full_name, "::");
+ strcat(full_name, old_name);
+
+ old_data = hv_fetch(hv, full_name, strlen(full_name), 0);
+
+ if (old_data) {
+ strcpy(full_name, new_pkg);
+ strcat(full_name, "::");
+ strcat(full_name, name);
+
+ SvREFCNT_inc(*old_data);
+ if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0))
+ SvREFCNT_dec(*old_data);
+ }
+ Safefree(full_name);
+ }
+
+ gv = (GV *) newSV(0);
+ gv_init(gv, stash, name, s - name, TRUE);
+
+ /*
+ * set_subname needs to create a GV to store the name. The CvGV field of a
+ * CV is not refcounted, so perl wouldn't know to SvREFCNT_dec() this GV if
+ * it destroys the containing CV. We use a MAGIC with an empty vtable
+ * simply for the side-effect of using MGf_REFCOUNTED to store the
+ * actually-counted reference to the GV.
+ */
+ mg = SvMAGIC(cv);
+ while (mg && mg->mg_virtual != &subname_vtbl)
+ mg = mg->mg_moremagic;
+ if (!mg) {
+ Newxz(mg, 1, MAGIC);
+ mg->mg_moremagic = SvMAGIC(cv);
+ mg->mg_type = PERL_MAGIC_ext;
+ mg->mg_virtual = &subname_vtbl;
+ SvMAGIC_set(cv, mg);
+ }
+ if (mg->mg_flags & MGf_REFCOUNTED)
+ SvREFCNT_dec(mg->mg_obj);
+ mg->mg_flags |= MGf_REFCOUNTED;
+ mg->mg_obj = (SV *) gv;
+ SvRMAGICAL_on(cv);
+ CvANON_off(cv);
+#ifndef CvGV_set
+ CvGV(cv) = gv;
+#else
+ CvGV_set(cv, gv);
+#endif
+ PUSHs(sub);
+
+void
+subname(code)
+ SV *code
+PREINIT:
+ CV *cv;
+ GV *gv;
+PPCODE:
+ if (!SvROK(code) && SvGMAGICAL(code))
+ mg_get(code);
+
+ if(!SvROK(code) || SvTYPE(cv = (CV *)SvRV(code)) != SVt_PVCV)
+ croak("Not a subroutine reference");
+
+ if(!(gv = CvGV(cv)))
+ XSRETURN(0);
+
+ mPUSHs(newSVpvf("%s::%s", HvNAME(GvSTASH(gv)), GvNAME(gv)));
+ XSRETURN(1);
+
BOOT:
{
HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
all any first min max minstr maxstr none notall product reduce sum sum0 shuffle
pairmap pairgrep pairfirst pairs pairkeys pairvalues
);
-our $VERSION = "1.39";
+our $VERSION = "1.41";
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
The remaining list-reduction functions are all specialisations of this generic
idea.
-=head2 $b = any { BLOCK } @list
+=head2 any
+
+ my $bool = any { BLOCK } @list;
I<Since version 1.33.>
# at least one string has more than 10 characters
}
-=head2 $b = all { BLOCK } @list
+=head2 all
+
+ my $bool = all { BLOCK } @list;
I<Since version 1.33.>
-Similar to C<any>, except that it requires all elements of the C<@list> to make
-the C<BLOCK> return true. If any element returns false, then it returns false.
-If the C<BLOCK> never returns false or the C<@list> was empty then it returns
-true.
+Similar to L</any>, except that it requires all elements of the C<@list> to
+make the C<BLOCK> return true. If any element returns false, then it returns
+false. If the C<BLOCK> never returns false or the C<@list> was empty then it
+returns true.
+
+=head2 none
-=head2 $b = none { BLOCK } @list
+=head2 notall
-=head2 $b = notall { BLOCK } @list
+ my $bool = none { BLOCK } @list;
+
+ my $bool = notall { BLOCK } @list;
I<Since version 1.33.>
-Similar to C<any> and C<all>, but with the return sense inverted. C<none>
-returns true only if no value in the LIST causes the BLOCK to return true, and
-C<notall> returns true only if not all of the values do.
+Similar to L</any> and L</all>, but with the return sense inverted. C<none>
+returns true only if no value in the C<@list> causes the C<BLOCK> to return
+true, and C<notall> returns true only if not all of the values do.
+
+=head2 first
-=head2 $val = first { BLOCK } @list
+ my $val = first { BLOCK } @list;
Similar to C<grep> in that it evaluates C<BLOCK> setting C<$_> to each element
of C<@list> in turn. C<first> returns the first element where the result from
$foo = first { $_ > $value } @list # first value in @list which
# is greater than $value
-=head2 $num = max @list
+=head2 max
+
+ my $num = max @list;
Returns the entry in the list with the highest numerical value. If the list is
empty then C<undef> is returned.
$foo = max 3,9,12 # 12
$foo = max @bar, @baz # whatever
-=head2 $str = maxstr @list
+=head2 maxstr
+
+ my $str = maxstr @list;
-Similar to C<max>, but treats all the entries in the list as strings and
+Similar to L</max>, but treats all the entries in the list as strings and
returns the highest string as defined by the C<gt> operator. If the list is
empty then C<undef> is returned.
$foo = maxstr "hello","world" # "world"
$foo = maxstr @bar, @baz # whatever
-=head2 $num = min @list
+=head2 min
+
+ my $num = min @list;
-Similar to C<max> but returns the entry in the list with the lowest numerical
+Similar to L</max> but returns the entry in the list with the lowest numerical
value. If the list is empty then C<undef> is returned.
$foo = min 1..10 # 1
$foo = min 3,9,12 # 3
$foo = min @bar, @baz # whatever
-=head2 $str = minstr @list
+=head2 minstr
-Similar to C<min>, but treats all the entries in the list as strings and
+ my $str = minstr @list;
+
+Similar to L</min>, but treats all the entries in the list as strings and
returns the lowest string as defined by the C<lt> operator. If the list is
empty then C<undef> is returned.
$foo = minstr "hello","world" # "hello"
$foo = minstr @bar, @baz # whatever
-=head2 $num = product @list
+=head2 product
+
+ my $num = product @list;
I<Since version 1.35.>
$foo = product 1..10 # 3628800
$foo = product 3,9,12 # 324
-=head2 $num_or_undef = sum @list
+=head2 sum
+
+ my $num_or_undef = sum @list;
Returns the numerical sum of all the elements in C<@list>. For backwards
compatibility, if C<@list> is empty then C<undef> is returned.
$foo = sum 3,9,12 # 24
$foo = sum @bar, @baz # whatever
-=head2 $num = sum0 @list
+=head2 sum0
+
+ my $num = sum0 @list;
I<Since version 1.26.>
-Similar to C<sum>, except this returns 0 when given an empty list, rather than
-C<undef>.
+Similar to L</sum>, except this returns 0 when given an empty list, rather
+than C<undef>.
=cut
=cut
-=head2 @kvlist = pairgrep { BLOCK } @kvlist
+=head2 pairgrep
+
+ my @kvlist = pairgrep { BLOCK } @kvlist;
-=head2 $count = pairgrep { BLOCK } @kvlist
+ my $count = pairgrep { BLOCK } @kvlist;
I<Since version 1.29.>
C<$b> to elements of the given list. Any modifications of it by the code block
will be visible to the caller.
-=head2 ( $key, $val ) = pairfirst { BLOCK } @kvlist
+=head2 pairfirst
-=head2 $found = pairfirst { BLOCK } @kvlist
+ my ( $key, $val ) = pairfirst { BLOCK } @kvlist;
+
+ my $found = pairfirst { BLOCK } @kvlist;
I<Since version 1.30.>
-Similar to the C<first> function, but interprets the given list as an
+Similar to the L</first> function, but interprets the given list as an
even-sized list of pairs. It invokes the C<BLOCK> multiple times, in scalar
context, with C<$a> and C<$b> set to successive pairs of values from the
C<@kvlist>.
C<$b> to elements of the given list. Any modifications of it by the code block
will be visible to the caller.
-=head2 @list = pairmap { BLOCK } @kvlist
+=head2 pairmap
+
+ my @list = pairmap { BLOCK } @kvlist;
-=head2 $count = pairmap { BLOCK } @kvlist
+ my $count = pairmap { BLOCK } @kvlist;
I<Since version 1.29.>
See L</KNOWN BUGS> for a known-bug with C<pairmap>, and a workaround.
-=head2 @pairs = pairs @kvlist
+=head2 pairs
+
+ my @pairs = pairs @kvlist;
I<Since version 1.29.>
...
}
-=head2 @keys = pairkeys @kvlist
+=head2 pairkeys
+
+ my @keys = pairkeys @kvlist;
I<Since version 1.29.>
@keys = pairmap { $a } @kvlist
-=head2 @values = pairvalues @kvlist
+=head2 pairvalues
+
+ my @values = pairvalues @kvlist;
I<Since version 1.29.>
=cut
-=head2 @values = shuffle @values
+=head2 shuffle
+
+ my @values = shuffle @values;
Returns the values of the input in a random order
L<https://rt.cpan.org/Ticket/Display.html?id=95409>
-If the block of code given to C<pairmap> contains lexical variables that are
+If the block of code given to L</pairmap> contains lexical variables that are
captured by a returned closure, and the closure is executed after the block
has been re-used for the next iteration, these lexicals will not see the
correct values. For example:
use strict;
use List::Util;
-our $VERSION = "1.39"; # FIXUP
+our $VERSION = "1.41"; # FIXUP
$VERSION = eval $VERSION; # FIXUP
1;
our @EXPORT_OK = qw(
blessed refaddr reftype weaken unweaken isweak
- dualvar isdual isvstring looks_like_number openhandle readonly set_prototype tainted
+ dualvar isdual isvstring looks_like_number openhandle readonly set_prototype
+ tainted
);
-our $VERSION = "1.39";
+our $VERSION = "1.41";
$VERSION = eval $VERSION;
our @EXPORT_FAIL;
@_;
}
+# set_prototype has been moved to Sub::Util with a different interface
+sub set_prototype(&$)
+{
+ my ( $code, $proto ) = @_;
+ return Sub::Util::set_prototype( $proto, $code );
+}
+
1;
__END__
The following functions all perform some useful activity on reference values.
-=head2 $pkg = blessed( $ref )
+=head2 blessed
+
+ my $pkg = blessed( $ref );
If C<$ref> is a blessed reference the name of the package that it is blessed
into is returned. Otherwise C<undef> is returned.
Take care when using this function simply as a truth test (such as in
C<if(blessed $ref)...>) because the package name C<"0"> is defined yet false.
-=head2 $addr = refaddr( $ref )
+=head2 refaddr
+
+ my $addr = refaddr( $ref );
If C<$ref> is reference the internal memory address of the referenced value is
returned as a plain integer. Otherwise C<undef> is returned.
$obj = bless {}, "Foo";
$addr = refaddr $obj; # eg 88123488
-=head2 $type = reftype( $ref )
+=head2 reftype
+
+ my $type = reftype( $ref );
If C<$ref> is a reference the basic Perl type of the variable referenced is
returned as a plain string (such as C<ARRAY> or C<HASH>). Otherwise C<undef>
$obj = bless {}, "Foo";
$type = reftype $obj; # HASH
-=head2 weaken( REF )
+=head2 weaken
-The lvalue C<REF> will be turned into a weak reference. This means that it
+ weaken( $ref );
+
+The lvalue C<$ref> will be turned into a weak reference. This means that it
will not hold a reference count on the object it references. Also when the
reference count on that object reaches zero, the reference will be set to
undef. This function mutates the lvalue passed as its argument and returns no
destroyed because there is now always a strong reference to them in the @object
array.
-=head2 unweaken( REF )
+=head2 unweaken
+
+ unweaken( $ref );
I<Since version 1.36.>
The lvalue C<REF> will be turned from a weak reference back into a normal
(strong) reference again. This function mutates the lvalue passed as its
argument and returns no value. This undoes the action performed by
-C<weaken()>.
+L</weaken>.
This function is slightly neater and more convenient than the
otherwise-equivalent code
(because in particular, simply assigning a weak reference back to itself does
not work to unweaken it; C<$REF = $REF> does not work).
-=head2 $weak = isweak( $ref )
+=head2 isweak
+
+ my $weak = isweak( $ref );
Returns true if C<$ref> is a weak reference.
=head1 OTHER FUNCTIONS
-=head2 $var = dualvar( $num, $string )
+=head2 dualvar
+
+ my $var = dualvar( $num, $string );
Returns a scalar that has the value C<$num> in a numeric context and the value
C<$string> in a string context.
$num = $foo + 2; # 12
$str = $foo . " world"; # Hello world
-=head2 $dual = isdual( $var )
+=head2 isdual
+
+ my $dual = isdual( $var );
I<Since version 1.26.>
$err = dualvar $!, $!;
$dual = isdual($err); # true
-=head2 $vstring = isvstring( $var )
+=head2 isvstring
+
+ my $vstring = isvstring( $var );
If C<$var> is a scalar which was coded as a vstring the result is true.
$fmt = isvstring($vs) ? "%vd" : "%s"; #true
printf($fmt,$vs);
-=head2 $isnum = looks_like_number( $var )
+=head2 looks_like_number
+
+ my $isnum = looks_like_number( $var );
Returns true if perl thinks C<$var> is a number. See
L<perlapi/looks_like_number>.
-=head2 $fh = openhandle( $fh )
+=head2 openhandle
+
+ my $fh = openhandle( $fh );
Returns C<$fh> itself if C<$fh> may be used as a filehandle and is open, or is
is a tied handle. Otherwise C<undef> is returned.
$fh = openhandle(*NOTOPEN); # undef
$fh = openhandle("scalar"); # undef
-=head2 $ro = readonly( $var )
+=head2 readonly
+
+ my $ro = readonly( $var );
Returns true if C<$var> is readonly.
$readonly = foo($bar); # false
$readonly = foo(0); # true
-=head2 $code = set_prototype( $code, $prototype )
+=head2 set_prototype
+
+ my $code = set_prototype( $code, $prototype );
Sets the prototype of the function given by the C<$code> reference, or deletes
it if C<$prototype> is C<undef>. Returns the C<$code> reference itself.
set_prototype \&foo, '$$';
-=head2 $t = tainted( $var )
+=head2 tainted
+
+ my $t = tainted( $var );
Return true if C<$var> is tainted.
=item Weak references are not implemented in the version of perl
The version of perl that you are using does not implement weak references, to
-use C<isweak> or C<weaken> you will need to use a newer release of perl.
+use L</isweak> or L</weaken> you will need to use a newer release of perl.
=item Vstrings are not implemented in the version of perl
The version of perl that you are using does not implement Vstrings, to use
-C<isvstring> you will need to use a newer release of perl.
+L</isvstring> you will need to use a newer release of perl.
=item C<NAME> is only available with the XS version of Scalar::Util
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
-Except weaken and isweak which are
+Additionally L</weaken> and L</isweak> which are
Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as perl itself.
+Copyright (C) 2004, 2008 Matthijs van Duin. All rights reserved.
+Copyright (C) 2014 cPanel Inc. All rights reserved.
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
=cut
--- /dev/null
+# Copyright (c) 2014 Paul Evans <leonerd@leonerd.org.uk>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Sub::Util;
+
+use strict;
+use warnings;
+
+require Exporter;
+require List::Util; # as it has the XS
+
+our @ISA = qw( Exporter );
+our @EXPORT_OK = qw(
+ prototype set_prototype
+ subname set_subname
+);
+
+our $VERSION = "1.41";
+$VERSION = eval $VERSION;
+
+=head1 NAME
+
+Sub::Util - A selection of utility subroutines for subs and CODE references
+
+=head1 SYNOPSIS
+
+ use Sub::Util qw( prototype set_prototype subname set_subname );
+
+=head1 DESCRIPTION
+
+C<Sub::Util> contains a selection of utility subroutines that are useful for
+operating on subs and CODE references.
+
+The rationale for inclusion in this module is that the function performs some
+work for which an XS implementation is essential because it cannot be
+implemented in Pure Perl, and which is sufficiently-widely used across CPAN
+that its popularity warrants inclusion in a core module, which this is.
+
+=cut
+
+=head1 FUNCTIONS
+
+=cut
+
+=head2 prototype
+
+ my $proto = prototype( $code )
+
+I<Since version 1.40.>
+
+Returns the prototype of the given C<$code> reference, if it has one, as a
+string. This is the same as the C<CORE::prototype> operator; it is included
+here simply for symmetry and completeness with the other functions.
+
+=cut
+
+sub prototype
+{
+ my ( $code ) = @_;
+ return CORE::prototype( $code );
+}
+
+=head2 set_prototype
+
+ my $code = set_prototype $prototype, $code;
+
+I<Since version 1.40.>
+
+Sets the prototype of the function given by the C<$code> reference, or deletes
+it if C<$prototype> is C<undef>. Returns the C<$code> reference itself.
+
+I<Caution>: This function takes arguments in a different order to the previous
+copy of the code from C<Scalar::Util>. This is to match the order of
+C<set_subname>, and other potential additions in this file. This order has
+been chosen as it allows a neat and simple chaining of other
+C<Sub::Util::set_*> functions as might become available, such as:
+
+ my $code =
+ set_subname name_here =>
+ set_prototype '&@' =>
+ set_attribute ':lvalue' =>
+ sub { ...... };
+
+=cut
+
+=head2 subname
+
+ my $name = subname( $code )
+
+I<Since version 1.40.>
+
+Returns the name of the given C<$code> reference, if it has one. Normal named
+subs will give a fully-qualified name consisting of the package and the
+localname separated by C<::>. Anonymous code references will give C<__ANON__>
+as the localname. If a name has been set using L</set_subname>, this name will
+be returned instead.
+
+This function was inspired by C<sub_fullname> from L<Sub::Identify>. The
+remaining functions that C<Sub::Identify> implements can easily be emulated
+using regexp operations, such as
+
+ sub get_code_info { return (subname $_[0]) =~ m/^(.+)::(.+?)$/ }
+ sub sub_name { return (get_code_info $_[0])[0] }
+ sub stash_name { return (get_code_info $_[0])[1] }
+
+I<Users of Sub::Name beware>: This function is B<not> the same as
+C<Sub::Name::subname>; it returns the existing name of the sub rather than
+changing it. To set or change a name, see instead L</set_subname>.
+
+=cut
+
+=head2 set_subname
+
+ my $code = set_subname $name, $code;
+
+I<Since version 1.40.>
+
+Sets the name of the function given by the C<$code> reference. Returns the
+C<$code> reference itself. If the C<$name> is unqualified, the package of the
+caller is used to qualify it.
+
+This is useful for applying names to anonymous CODE references so that stack
+traces and similar situations, to give a useful name rather than having the
+default of C<__ANON__>. Note that this name is only used for this situation;
+the C<set_subname> will not install it into the symbol table; you will have to
+do that yourself if required.
+
+However, since the name is not used by perl except as the return value of
+C<caller>, for stack traces or similar, there is no actual requirement that
+the name be syntactically valid as a perl function name. This could be used to
+attach extra information that could be useful in debugging stack traces.
+
+This function was copied from C<Sub::Name::subname> and renamed to the naming
+convention of this module.
+
+=cut
+
+=head1 AUTHOR
+
+The general structure of this module was written by Paul Evans
+<leonerd@leonerd.org.uk>.
+
+The XS implementation of L</set_subname> was copied from L<Sub::Name> by
+Matthijs van Duin <xmath@cpan.org>
+
+=cut
+
+1;
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+
+use Sub::Util qw( prototype set_prototype );
+use Test::More tests => 13;
+
+sub f { }
+is( prototype('f'), undef, 'no prototype');
+is( CORE::prototype('f'), undef, 'no prototype from CORE');
+
+my $r = set_prototype('$', \&f);
+is( prototype('f'), '$', 'prototype');
+is( CORE::prototype('f'), '$', 'prototype from CORE');
+is( $r, \&f, 'return value');
+
+set_prototype(undef, \&f);
+is( prototype('f'), undef, 'remove prototype');
+
+set_prototype('', \&f);
+is( prototype('f'), '', 'empty prototype');
+
+sub g (@) { }
+is( prototype('g'), '@', '@ prototype');
+
+set_prototype(undef, \&g);
+is( prototype('g'), undef, 'remove prototype');
+
+sub stub;
+is( prototype('stub'), undef, 'non existing sub');
+
+set_prototype('$$$', \&stub);
+is( prototype('stub'), '$$$', 'change non existing sub');
+
+sub f_decl ($$$$);
+is( prototype('f_decl'), '$$$$', 'forward declaration');
+
+set_prototype('\%', \&f_decl);
+is( prototype('f_decl'), '\%', 'change forward declaration');
use List::Util qw(reduce min);
use Test::More;
-plan tests => 29 + ($::PERL_ONLY ? 0 : 2);
+plan tests => 30 + ($::PERL_ONLY ? 0 : 2);
my $v = reduce {};
eval { &reduce(+{},1,2,3) };
ok($@ =~ /^Not a subroutine reference/, 'check for code reference');
+my @names = ("a\x{100}c", "d\x{101}efgh", 'ijk');
+my $longest = reduce { length($a) > length($b) ? $a : $b } @names;
+is( length($longest), 6, 'missing SMG rt#121992');
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { $^P |= 0x210 }
+
+use Test::More tests => 18;
+
+use B::Deparse;
+use Sub::Util qw( subname set_subname );
+
+{
+ sub localfunc {}
+ sub fully::qualified::func {}
+
+ is(subname(\&subname), "Sub::Util::subname",
+ 'subname of \&subname');
+ is(subname(\&localfunc), "main::localfunc",
+ 'subname of \&localfunc');
+ is(subname(\&fully::qualified::func), "fully::qualified::func",
+ 'subname of \&fully::qualfied::func');
+
+ # Because of the $^P debug flag, we'll get [file:line] as well
+ like(subname(sub {}), qr/^main::__ANON__\[.+:\d+\]$/, 'subname of anon sub');
+
+ ok(!eval { subname([]) }, 'subname [] dies');
+}
+
+my $x = set_subname foo => sub { (caller 0)[3] };
+my $line = __LINE__ - 1;
+my $file = __FILE__;
+my $anon = $DB::sub{"main::__ANON__[${file}:${line}]"};
+
+is($x->(), "main::foo");
+
+{
+ package Blork;
+
+ use Sub::Util qw( set_subname );
+
+ set_subname " Bar!", $x;
+ ::is($x->(), "Blork:: Bar!");
+
+ set_subname "Foo::Bar::Baz", $x;
+ ::is($x->(), "Foo::Bar::Baz");
+
+ set_subname "set_subname (dynamic $_)", \&set_subname for 1 .. 3;
+
+ for (4 .. 5) {
+ set_subname "Dynamic $_", $x;
+ ::is($x->(), "Blork::Dynamic $_");
+ }
+
+ ::is($DB::sub{"main::foo"}, $anon);
+
+ for (4 .. 5) {
+ ::is($DB::sub{"Blork::Dynamic $_"}, $anon);
+ }
+
+ for ("Blork:: Bar!", "Foo::Bar::Baz") {
+ ::is($DB::sub{$_}, $anon);
+ }
+}
+
+# RT42725
+{
+ my $source = eval {
+ B::Deparse->new->coderef2text(set_subname foo => sub{ @_ });
+ };
+
+ ok !$@;
+
+ like $source, qr/\@\_/;
+}
+
+# subname of set_subname
+{
+ is(subname(set_subname "my-scary-name-here", sub {}), "main::my-scary-name-here",
+ 'subname of set_subname');
+}
+
+# vim: ft=perl
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
use constant GOT_TIME_HIRES => do {
eval 'use Time::HiRes qw(time);';
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head2 C<< open_test >>
-See L<TAP::Formatter::base>
+See L<TAP::Formatter::Base>
=cut
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 METHODS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
$ENV{HARNESS_ACTIVE} = 1;
$ENV{HARNESS_VERSION} = $VERSION;
use TAP::Object;
use Text::ParseWords qw/shellwords/;
-our $VERSION = '3.32';
+our $VERSION = '3.33';
# Get the parts of @INC which are changed from the stock list AND
# preserve reordering of stock directories.
=head1 VERSION
-Version 3.32
+Version 3.33
=head1 SYNOPSIS
- my ($class, $args) = get_test_arguments();
- require_module($class);
- $class->new($args);
+ my $harness = TAP::Harness::Env->create(\%extra_args)
=head1 DESCRIPTION
-This module implements the environmental variables that L<Test::Harness> for use with TAP::Harness.
+This module implements the environmental variables that L<Test::Harness> for use with TAP::Harness, and instantiates it with the appropriate arguments.
-=head1 FUNCTIONS
+=over 4
+
+=item * HARNESS_PERL_SWITCHES
+
+=item * HARNESS_VERBOSE
+
+=item * HARNESS_SUBCLASS
+
+=item * HARNESS_OPTIONS
+
+=item * HARNESS_TIMER
+
+=item * HARNESS_COLOR
+
+=item * HARNESS_IGNORE_EXIT
+
+=back
+
+=head1 METHODS
=over 4
-=item * get_test_options( \%args )
+=item * create( \%args )
-This function reads the environment and generates an appropriate argument hash from it. If given any arguments, there will override the environmental defaults. It will return of C<$class> and C<$args>.
+This function reads the environment and generates an appropriate argument hash from it. If given any arguments in C<%extra_args>, these will override the environmental defaults. In accepts C<harness_class> (which defaults to C<TAP::Harness>), and any argument the harness class accepts.
=back
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
my $DEFAULT_TAP_VERSION = 12;
my $MAX_TAP_VERSION = 13;
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head2 DESCRIPTION
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head3 Rules resolution
-=over4
+=over 4
=item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one.
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
=head1 SYNOPSIS
use base 'TAP::Object';
-our $VERSION = '3.32';
+our $VERSION = '3.33';
# TODO:
# Handle blessed object syntax
=head1 VERSION
-Version 3.32
+Version 3.33
=head1 SYNOPSIS
use base 'TAP::Object';
-our $VERSION = '3.32';
+our $VERSION = '3.33';
my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
=head1 VERSION
-Version 3.32
+Version 3.33
=head1 SYNOPSIS
=head1 VERSION
-Version 3.32
+Version 3.33
=cut
-our $VERSION = '3.32';
+our $VERSION = '3.33';
# Backwards compatibility for exportable variable names.
*verbose = *Verbose;
use strict;
use warnings;
-our $VERSION = '1.001003';
+our $VERSION = '1.001006';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
BEGIN {
=head1 DESCRIPTION
-Test::Simple and Test::More have proven to be popular testing modules,
+L<Test::Simple> and L<Test::More> have proven to be popular testing modules,
but they're not always flexible enough. Test::Builder provides a
building block upon which to write your own test libraries I<which can
work together>.
=item B<subtest>
- $builder->subtest($name, \&subtests);
+ $builder->subtest($name, \&subtests, @args);
-See documentation of C<subtest> in Test::More.
+See documentation of C<subtest> in Test::More.
+
+C<subtest> also, and optionally, accepts arguments which will be passed to the
+subtests reference.
=cut
sub subtest {
my $self = shift;
- my($name, $subtests) = @_;
+ my($name, $subtests, @args) = @_;
if ('CODE' ne ref $subtests) {
$self->croak("subtest()'s second argument must be a code ref");
my $run_the_subtests = sub {
# Add subtest name for clarification of starting point
$self->note("Subtest: $name");
- $subtests->();
+ $subtests->(@args);
$self->done_testing unless $self->_plan_handled;
1;
};
When your child is done running tests, you must call C<finalize> to clean up
and tell the parent your pass/fail status.
-Calling finalize on a child with open children will C<croak>.
+Calling C<finalize> on a child with open children will C<croak>.
If the child falls out of scope before C<finalize> is called, a failure
diagnostic will be issued and the child is considered to have failed.
$Test->isnt_eq($got, $dont_expect, $name);
-Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
+Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is
the string version.
=item B<isnt_num>
$Test->isnt_num($got, $dont_expect, $name);
-Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
+Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is
the numeric version.
=cut
$Test->like($thing, qr/$regex/, $name);
$Test->like($thing, '/$regex/', $name);
-Like Test::More's C<like()>. Checks if $thing matches the given C<$regex>.
+Like L<Test::More>'s C<like()>. Checks if $thing matches the given C<$regex>.
=item B<unlike>
$Test->unlike($thing, qr/$regex/, $name);
$Test->unlike($thing, '/$regex/', $name);
-Like Test::More's C<unlike()>. Checks if $thing B<does not match> the
+Like L<Test::More>'s C<unlike()>. Checks if $thing B<does not match> the
given C<$regex>.
=cut
$Test->cmp_ok($thing, $type, $that, $name);
-Works just like Test::More's C<cmp_ok()>.
+Works just like L<Test::More>'s C<cmp_ok()>.
$Test->cmp_ok($big_num, '!=', $other_big_num);
$Test->BAIL_OUT($reason);
-Indicates to the Test::Harness that things are going so badly all
+Indicates to the L<Test::Harness> that things are going so badly all
testing should terminate. This includes running any additional test
scripts.
the caller based on C<$Level + 1>, since C<todo()> is usually called inside
a test function. As a last resort it will use C<exported_to()>.
-Sometimes there is some confusion about where todo() should be looking
+Sometimes there is some confusion about where C<todo()> should be looking
for the C<$TODO> variable. If you want to be sure, tell it explicitly
what $pack to use.
=head1 MEMORY
-An informative hash, accessible via C<<details()>>, is stored for each
+An informative hash, accessible via C<details()>, is stored for each
test you perform. So memory usage will scale linearly with each test
run. Although this is not a problem for most test suites, it can
become an issue if you do large (hundred thousands to million)
In such cases, you are advised to either split the test file into smaller
ones, or use a reverse approach, doing "normal" (code) compares and
-triggering fail() should anything go unexpected.
+triggering C<fail()> should anything go unexpected.
Future versions of Test::Builder will have a way to turn history off.
=head1 EXAMPLES
-CPAN can provide the best examples. Test::Simple, Test::More,
-Test::Exception and Test::Differences all use Test::Builder.
+CPAN can provide the best examples. L<Test::Simple>, L<Test::More>,
+L<Test::Exception> and L<Test::Differences> all use Test::Builder.
=head1 SEE ALSO
-Test::Simple, Test::More, Test::Harness
+L<Test::Simple>, L<Test::More>, L<Test::Harness>
=head1 AUTHORS
require Exporter;
our @ISA = qw(Exporter);
-our $VERSION = '1.001003';
+our $VERSION = '1.001006';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
=head1 DESCRIPTION
-This is a superclass for Test::Builder-based modules. It provides a
+This is a superclass for L<Test::Builder>-based modules. It provides a
handful of common functionality and a method of getting at the underlying
-Test::Builder object.
+L<Test::Builder> object.
=head2 Importing
-Test::Builder::Module is a subclass of Exporter which means your
+Test::Builder::Module is a subclass of L<Exporter> which means your
module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc...
all act normally.
-A few methods are provided to do the C<use Your::Module tests => 23> part
+A few methods are provided to do the C<< use Your::Module tests => 23 >> part
for you.
=head3 import
-Test::Builder::Module provides an import() method which acts in the
-same basic way as Test::More's, setting the plan and controlling
+Test::Builder::Module provides an C<import()> method which acts in the
+same basic way as L<Test::More>'s, setting the plan and controlling
exporting of functions and variables. This allows your module to set
-the plan independent of Test::More.
+the plan independent of L<Test::More>.
-All arguments passed to import() are passed onto
+All arguments passed to C<import()> are passed onto
C<< Your::Module->builder->plan() >> with the exception of
C<< import =>[qw(things to import)] >>.
use Your::Module import => [qw(this that)], tests => 23;
-says to import the functions this() and that() as well as set the plan
+says to import the functions C<this()> and C<that()> as well as set the plan
to be 23 tests.
-import() also sets the exported_to() attribute of your builder to be
-the caller of the import() function.
+C<import()> also sets the C<exported_to()> attribute of your builder to be
+the caller of the C<import()> function.
-Additional behaviors can be added to your import() method by overriding
-import_extra().
+Additional behaviors can be added to your C<import()> method by overriding
+C<import_extra()>.
=cut
Your::Module->import_extra(\@import_args);
-import_extra() is called by import(). It provides an opportunity for you
+C<import_extra()> is called by C<import()>. It provides an opportunity for you
to add behaviors to your module based on its import list.
-Any extra arguments which shouldn't be passed on to plan() should be
+Any extra arguments which shouldn't be passed on to C<plan()> should be
stripped off by this method.
-See Test::More for an example of its use.
+See L<Test::More> for an example of its use.
B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it
feels like a bit of an ugly hack in its current form.
my $builder = Your::Class->builder;
-This method returns the Test::Builder object associated with Your::Class.
+This method returns the L<Test::Builder> object associated with Your::Class.
It is not a constructor so you can call it as often as you like.
-This is the preferred way to get the Test::Builder object. You should
+This is the preferred way to get the L<Test::Builder> object. You should
I<not> get it via C<< Test::Builder->new >> as was previously
recommended.
-The object returned by builder() may change at runtime so you should
-call builder() inside each function rather than store it in a global.
+The object returned by C<builder()> may change at runtime so you should
+call C<builder()> inside each function rather than store it in a global.
sub ok {
my $builder = Your::Class->builder;
package Test::Builder::Tester;
use strict;
-our $VERSION = "1.23_003";
+our $VERSION = "1.24";
use Test::Builder 0.98;
use Symbol;
=head1 DESCRIPTION
A module that helps you test testing modules that are built with
-B<Test::Builder>.
+L<Test::Builder>.
The testing system is designed to be used by performing a three step
process for each test you wish to test. This process starts with using
C<test_out> and C<test_err> in advance to declare what the testsuite you
-are testing will output with B<Test::Builder> to stdout and stderr.
+are testing will output with L<Test::Builder> to stdout and stderr.
You then can run the test(s) from your test suite that call
-B<Test::Builder>. At this point the output of B<Test::Builder> is
-safely captured by B<Test::Builder::Tester> rather than being
+L<Test::Builder>. At this point the output of L<Test::Builder> is
+safely captured by L<Test::Builder::Tester> rather than being
interpreted as real test output.
The final stage is to call C<test_test> that will simply compare what you
-predeclared to what B<Test::Builder> actually outputted, and report the
+predeclared to what L<Test::Builder> actually outputted, and report the
results back with a "ok" or "not ok" (with debugging) to the normal
output.
test_out("ok 2");
Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have
-been called, all further output from B<Test::Builder> will be
-captured by B<Test::Builder::Tester>. This means that you will not
+been called, all further output from L<Test::Builder> will be
+captured by L<Test::Builder::Tester>. This means that you will not
be able perform further tests to the normal output in the normal way
until you call C<test_test> (well, unless you manually meddle with the
output filehandles)
=item test_fail
-Because the standard failure message that B<Test::Builder> produces
+Because the standard failure message that L<Test::Builder> produces
whenever a test fails will be a common occurrence in your test error
output, and because it has changed between Test::Builder versions, rather
than forcing you to call C<test_err> with the string all the time like
=item test_diag
As most of the remaining expected output to the error stream will be
-created by Test::Builder's C<diag> function, B<Test::Builder::Tester>
+created by L<Test::Builder>'s C<diag> function, L<Test::Builder::Tester>
provides a convenience function C<test_diag> that you can use instead of
C<test_err>.
test_diag("Couldn't open file");
-Remember that B<Test::Builder>'s diag function will not add newlines to
+Remember that L<Test::Builder>'s diag function will not add newlines to
the end of output and test_diag will. So to check
Test::Builder->new->diag("foo\n","bar\n");
=item test_test
Actually performs the output check testing the tests, comparing the
-data (with C<eq>) that we have captured from B<Test::Builder> against
+data (with C<eq>) that we have captured from L<Test::Builder> against
what was declared with C<test_out> and C<test_err>.
This takes name/value pairs that effect how the test is run.
is assumed to be the name of the test (as in the above examples.)
Once C<test_test> has been run test output will be redirected back to
-the original filehandles that B<Test::Builder> was connected to
+the original filehandles that L<Test::Builder> was connected to
(probably STDOUT and STDERR,) meaning any further tests you run
-will function normally and cause success/errors for B<Test::Harness>.
+will function normally and cause success/errors for L<Test::Harness>.
=cut
current setting.
To enable colouring from the command line, you can use the
-B<Text::Builder::Tester::Color> module like so:
+L<Text::Builder::Tester::Color> module like so:
perl -Mlib=Text::Builder::Tester::Color test.t
-Or by including the B<Test::Builder::Tester::Color> module directly in
+Or by including the L<Test::Builder::Tester::Color> module directly in
the PERL5LIB.
=cut
=head1 BUGS
-Calls C<<Test::Builder->no_ending>> turning off the ending tests.
+Calls C<< Test::Builder->no_ending >> turning off the ending tests.
This is needed as otherwise it will trip out because we've run more
tests than we strictly should have and it'll register any failures we
had that we were testing for as real failures.
-The color function doesn't work unless B<Term::ANSIColor> is
+The color function doesn't work unless L<Term::ANSIColor> is
compatible with your terminal.
Bugs (and requests for new features) can be reported to the author
Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
-Some code taken from B<Test::More> and B<Test::Catch>, written by
+Some code taken from L<Test::More> and L<Test::Catch>, written by
Michael G Schwern E<lt>schwern@pobox.comE<gt>. Hence, those parts
Copyright Micheal G Schwern 2001. Used and distributed with
permission.
package Test::Builder::Tester::Color;
use strict;
-our $VERSION = "1.23_002";
+our $VERSION = "1.24";
require Test::Builder::Tester;
# We use a lot of subroutine prototypes
## no critic (Subroutines::ProhibitSubroutinePrototypes)
-# Can't use Carp because it might cause use_ok() to accidentally succeed
+# Can't use Carp because it might cause C<use_ok()> to accidentally succeed
# even though the module being used forgot to use Carp. Yes, this
# actually happened.
sub _carp {
return warn @_, " at $file line $line\n";
}
-our $VERSION = '1.001003';
+our $VERSION = '1.001006';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
use Test::Builder::Module 0.99;
use Test::More tests => 23, import => ['!fail'];
-Alternatively, you can use the plan() function. Useful for when you
+Alternatively, you can use the C<plan()> function. Useful for when you
have to calculate the number of tests.
use Test::More;
If you don't know how many tests you're going to run, you can issue
the plan when you're done running tests.
-$number_of_tests is the same as plan(), it's the number of tests you
+$number_of_tests is the same as C<plan()>, it's the number of tests you
expected to run. You can omit this, in which case the number of tests
you ran doesn't matter, just the fact that your tests ran to
conclusion.
and gives others an idea of your intentions. $test_name is optional,
but we B<very> strongly encourage its use.
-Should an ok() fail, it will produce some diagnostics:
+Should an C<ok()> fail, it will produce some diagnostics:
not ok 18 - sufficient mucus
# Failed test 'sufficient mucus'
# in foo.t at line 42.
-This is the same as Test::Simple's ok() routine.
+This is the same as L<Test::Simple>'s C<ok()> routine.
=cut
is ( $got, $expected, $test_name );
isnt( $got, $expected, $test_name );
-Similar to ok(), is() and isnt() compare their two arguments
+Similar to C<ok()>, C<is()> and C<isnt()> compare their two arguments
with C<eq> and C<ne> respectively and use the result of that to
determine if the test succeeded or failed. So these:
(Mnemonic: "This is that." "This isn't that.")
-So why use these? They produce better diagnostics on failure. ok()
-cannot know what you are testing for (beyond the name), but is() and
-isnt() know what the test was and why it failed. For example this
+So why use these? They produce better diagnostics on failure. C<ok()>
+cannot know what you are testing for (beyond the name), but C<is()> and
+C<isnt()> know what the test was and why it failed. For example this
test:
my $foo = 'waffle'; my $bar = 'yarblokos';
So you can figure out what went wrong without rerunning the test.
-You are encouraged to use is() and isnt() over ok() where possible,
+You are encouraged to use C<is()> and C<isnt()> over C<ok()> where possible,
however do not be tempted to use them to find out if something is
true or false!
This does not check if C<exists $brooklyn{tree}> is true, it checks if
it returns 1. Very different. Similar caveats exist for false and 0.
-In these cases, use ok().
+In these cases, use C<ok()>.
ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' );
-A simple call to isnt() usually does not provide a strong test but there
+A simple call to C<isnt()> usually does not provide a strong test but there
are cases when you cannot say much more about a value than that it is
different from some other value:
isnt $obj, $clone, "clone() produces a different object";
For those grammatical pedants out there, there's an C<isn't()>
-function which is an alias of isnt().
+function which is an alias of C<isnt()>.
=cut
}
*isn't = \&isnt;
+# ' to unconfuse syntax higlighters
=item B<like>
like( $got, qr/expected/, $test_name );
-Similar to ok(), like() matches $got against the regex C<qr/expected/>.
+Similar to C<ok()>, C<like()> matches $got against the regex C<qr/expected/>.
So this:
Regex options may be placed on the end (C<'/expected/i'>).
-Its advantages over ok() are similar to that of is() and isnt(). Better
+Its advantages over C<ok()> are similar to that of C<is()> and C<isnt()>. Better
diagnostics on failure.
=cut
unlike( $got, qr/expected/, $test_name );
-Works exactly as like(), only it checks if $got B<does not> match the
+Works exactly as C<like()>, only it checks if $got B<does not> match the
given pattern.
=cut
cmp_ok( $got, '&&', $expected, 'this && that' );
...etc...
-Its advantage over ok() is when the test fails you'll know what $got
+Its advantage over C<ok()> is when the test fails you'll know what $got
and $expected were:
not ok 1
# undef
It's also useful in those cases where you are comparing numbers and
-is()'s use of C<eq> will interfere:
+C<is()>'s use of C<eq> will interfere:
cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
only without all the typing and with a better interface. Handy for
quickly testing an interface.
-No matter how many @methods you check, a single can_ok() call counts
+No matter how many @methods you check, a single C<can_ok()> call counts
as one test. If you desire otherwise, use:
foreach my $meth (@methods) {
my $obj = new_ok( $class => \@args, $object_name );
A convenience function which combines creating an object and calling
-isa_ok() on that object.
+C<isa_ok()> on that object.
It is basically equivalent to:
If @args is not given, an empty list will be used.
-This function only works on new() and it assumes new() will return
+This function only works on C<new()> and it assumes C<new()> will return
just a single object which isa C<$class>.
=cut
subtest $name => \&code;
-subtest() runs the &code as its own little test with its own plan and
+C<subtest()> runs the &code as its own little test with its own plan and
its own result. The main test counts this as a single test using the
result of the whole subtest to determine if its ok or not ok.
ok 2 - An example subtest
ok 3 - Third test
-A subtest may call "skip_all". No tests will be run, but the subtest is
+A subtest may call C<skip_all>. No tests will be run, but the subtest is
considered a skip.
subtest 'skippy' => sub {
Sometimes you just want to say that the tests have passed. Usually
the case is you've got some complicated condition that is difficult to
-wedge into an ok(). In this case, you can simply use pass() (to
+wedge into an C<ok()>. In this case, you can simply use C<pass()> (to
declare the test ok) or fail (for not ok). They are synonyms for
-ok(1) and ok(0).
+C<ok(1)> and C<ok(0)>.
Use these very, very, very sparingly.
If you just want to load a module in a test, we recommend simply using
C<use> directly. It will cause the test to stop.
-It's recommended that you run use_ok() inside a BEGIN block so its
+It's recommended that you run C<use_ok()> inside a BEGIN block so its
functions are exported at compile-time and prototypes are properly
honored.
is_deeply( $got, $expected, $test_name );
-Similar to is(), except that if $got and $expected are references, it
+Similar to C<is()>, except that if $got and $expected are references, it
does a deep comparison walking each data structure to see if they are
equivalent. If the two structures are different, it will display the
place where they start differing.
-is_deeply() compares the dereferenced values of references, the
+C<is_deeply()> compares the dereferenced values of references, the
references themselves (except for their type) are ignored. This means
aspects such as blessing and ties are not considered "different".
-is_deeply() currently has very limited handling of function reference
+C<is_deeply()> currently has very limited handling of function reference
and globs. It merely checks if they have the same referent. This may
improve in the future.
note(@diagnostic_message);
-Like diag(), except the message will not be seen when the test is run
+Like C<diag()>, except the message will not be seen when the test is run
in a harness. It will only be visible in the verbose TAP stream.
Handy for putting in notes which might be useful for debugging, but
Sometimes running a test under certain conditions will cause the
test script to die. A certain function or method isn't implemented
-(such as fork() on MacOS), some resource isn't available (like a
+(such as C<fork()> on MacOS), some resource isn't available (like a
net connection) or a module isn't available. In these cases it's
necessary to skip tests, or declare that they are supposed to fail
but will work in the future (a todo test).
With a todo block, the tests inside are expected to fail. Test::More
will run the tests normally, but print out special flags indicating
-they are "todo". Test::Harness will interpret failures as being ok.
+they are "todo". L<Test::Harness> will interpret failures as being ok.
Should anything succeed, it will report it as an unexpected success.
You then know the thing you had todo is done and can remove the
TODO flag.
cases you have no choice but to skip over the broken tests entirely.
The syntax and behavior is similar to a C<SKIP: BLOCK> except the
-tests will be marked as failing but todo. Test::Harness will
+tests will be marked as failing but todo. L<Test::Harness> will
interpret them as passing.
=cut
B<If it's something the user might not be able to do>, use SKIP.
This includes optional modules that aren't installed, running under
-an OS that doesn't have some feature (like fork() or symlinks), or maybe
+an OS that doesn't have some feature (like C<fork()> or symlinks), or maybe
you need an Internet connection and one isn't available.
B<If it's something the programmer hasn't done yet>, use TODO. This
The use of the following functions is discouraged as they are not
actually testing functions and produce no diagnostics to help figure
-out what went wrong. They were written before is_deeply() existed
+out what went wrong. They were written before C<is_deeply()> existed
because I couldn't figure out how to display a useful diff of two
arbitrary data structures.
-These functions are usually used inside an ok().
+These functions are usually used inside an C<ok()>.
ok( eq_array(\@got, \@expected) );
my $is_eq = eq_set(\@got, \@expected);
-Similar to eq_array(), except the order of the elements is B<not>
+Similar to C<eq_array()>, except the order of the elements is B<not>
important. This is a deep check, but the irrelevancy of order only
applies to the top level.
B<NOTE> By historical accident, this is not a true set comparison.
While the order of elements does not matter, duplicate elements do.
-B<NOTE> eq_set() does not know how to deal with references at the top
+B<NOTE> C<eq_set()> does not know how to deal with references at the top
level. The following is an example of a comparison which might not work:
eq_set([\1, \2], [\2, \1]);
=head2 Extending and Embedding Test::More
Sometimes the Test::More interface isn't quite enough. Fortunately,
-Test::More is built on top of Test::Builder which provides a single,
+Test::More is built on top of L<Test::Builder> which provides a single,
unified backend for any test library to use. This means two test
-libraries which both use Test::Builder B<can be used together in the
+libraries which both use <Test::Builder> B<can> be used together in the
same program>.
If you simply want to do a little tweaking of how the tests behave,
-you can access the underlying Test::Builder object like so:
+you can access the underlying L<Test::Builder> object like so:
=over 4
my $test_builder = Test::More->builder;
-Returns the Test::Builder object underlying Test::More for you to play
+Returns the L<Test::Builder> object underlying Test::More for you to play
with.
=head1 EXIT CODES
-If all your tests passed, Test::Builder will exit with zero (which is
+If all your tests passed, L<Test::Builder> will exit with zero (which is
normal). If anything failed it will exit with how many failed. If
you run less (or more) tests than you planned, the missing (or extras)
-will be considered failures. If no tests were ever run Test::Builder
+will be considered failures. If no tests were ever run L<Test::Builder>
will throw a warning and exit with 255. If the test died, even after
having successfully completed all its tests, it will still be
considered a failure and will exit with 255.
=item utf8 / "Wide character in print"
If you use utf8 or other non-ASCII characters with Test::More you
-might get a "Wide character in print" warning. Using C<binmode
-STDOUT, ":utf8"> will not fix it. Test::Builder (which powers
+might get a "Wide character in print" warning. Using
+C<< binmode STDOUT, ":utf8" >> will not fix it.
+L<Test::Builder> (which powers
Test::More) duplicates STDOUT and STDERR. So any changes to them,
including changing their output disciplines, will not be seem by
Test::More.
use Test::More;
A more direct work around is to change the filehandles used by
-Test::Builder.
+L<Test::Builder>.
my $builder = Test::More->builder;
binmode $builder->output, ":encoding(utf8)";
=item Overloaded objects
-String overloaded objects are compared B<as strings> (or in cmp_ok()'s
+String overloaded objects are compared B<as strings> (or in C<cmp_ok()>'s
case, strings or numbers as appropriate to the comparison op). This
prevents Test::More from piercing an object's interface allowing
better blackbox testing. So if a function starts returning overloaded
objects instead of bare strings your tests won't notice the
difference. This is good.
-However, it does mean that functions like is_deeply() cannot be used to
+However, it does mean that functions like C<is_deeply()> cannot be used to
test the internals of string overloaded objects. In this case I would
suggest L<Test::Deep> which contains more flexible testing functions for
complex data structures.
=item Threads
-Test::More will only be aware of threads if "use threads" has been done
+Test::More will only be aware of threads if C<use threads> has been done
I<before> Test::More is loaded. This is ok:
use threads;
=head1 HISTORY
-This is a case of convergent evolution with Joshua Pritikin's Test
+This is a case of convergent evolution with Joshua Pritikin's L<Test>
module. I was largely unaware of its existence when I'd first
-written my own ok() routines. This module exists because I can't
+written my own C<ok()> routines. This module exists because I can't
figure out how to easily wedge test names into Test's interface (along
with a few other problems).
=head1 SEE ALSO
+=head2
+
+=head2 ALTERNATIVES
+
L<Test::Simple> if all this confuses you and you just want to write
some tests. You can upgrade to Test::More later (it's forward
compatible).
-L<Test::Harness> is the test runner and output interpreter for Perl.
-It's the thing that powers C<make test> and where the C<prove> utility
-comes from.
-
L<Test::Legacy> tests written with Test.pm, the original testing
module, do not play well with other testing libraries. Test::Legacy
emulates the Test.pm interface and does play well with others.
+=head2 TESTING FRAMEWORKS
+
+L<Fennec> The Fennec framework is a testers toolbox. It uses L<Test::Builder>
+under the hood. It brings enhancements for forking, defining state, and
+mocking. Fennec enhances several modules to work better together than they
+would if you loaded them individually on your own.
+
+L<Fennec::Declare> Provides enhanced (L<Devel::Declare>) syntax for Fennec.
+
+=head2 ADDITIONAL LIBRARIES
+
L<Test::Differences> for more ways to test complex data structures.
And it plays well with Test::More.
L<Test::Inline> shows the idea of embedded testing.
+L<Mock::Quick> The ultimate mocking library. Easily spawn objects defined on
+the fly. Can also override, block, or reimplement packages as needed.
+
+L<Test::FixtureBuilder> Quickly define fixture data for unit tests.
+
+=head2 OTHER COMPONENTS
+
+L<Test::Harness> is the test runner and output interpreter for Perl.
+It's the thing that powers C<make test> and where the C<prove> utility
+comes from.
+
+=head2 BUNDLES
+
L<Bundle::Test> installs a whole bunch of useful test modules.
+L<Test::Most> Most commonly needed test functions and features.
=head1 AUTHORS
use strict;
-our $VERSION = '1.001003';
+our $VERSION = '1.001006';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
use Test::Builder::Module 0.99;
=head1 DESCRIPTION
-** If you are unfamiliar with testing B<read Test::Tutorial> first! **
+** If you are unfamiliar with testing B<read L<Test::Tutorial> first!> **
This is an extremely simple, extremely basic module for writing tests
suitable for CPAN modules and other pursuits. If you wish to do more
The basic unit of Perl testing is the ok. For each thing you want to
test your program will print out an "ok" or "not ok" to indicate pass
-or fail. You do this with the ok() function (see below).
+or fail. You do this with the C<ok()> function (see below).
The only other constraint is you must pre-declare how many tests you
plan to run. This is in case something goes horribly wrong during the
ok( $foo eq $bar, $name );
ok( $foo eq $bar );
-ok() is given an expression (in this case C<$foo eq $bar>). If it's
+C<ok()> is given an expression (in this case C<$foo eq $bar>). If it's
true, the test passed. If it's false, it didn't. That's about it.
-ok() prints out either "ok" or "not ok" along with a test number (it
+C<ok()> prints out either "ok" or "not ok" along with a test number (it
keeps track of that for you).
# This produces "ok 1 - Hell not yet frozen over" (or not ok)
Test::Simple will start by printing number of tests run in the form
"1..M" (so "1..5" means you're going to run 5 tests). This strange
-format lets Test::Harness know how many tests you plan on running in
+format lets L<Test::Harness> know how many tests you plan on running in
case something goes horribly wrong.
If all your tests passed, Test::Simple will exit with zero (which is
=item L<Test::More>
More testing functions! Once you outgrow Test::Simple, look at
-Test::More. Test::Simple is 100% forward compatible with Test::More
-(i.e. you can just use Test::More instead of Test::Simple in your
+L<Test::More>. Test::Simple is 100% forward compatible with L<Test::More>
+(i.e. you can just use L<Test::More> instead of Test::Simple in your
programs and things will still work).
=back
-Look in Test::More's SEE ALSO for more testing modules.
+Look in L<Test::More>'s SEE ALSO for more testing modules.
=head1 AUTHORS
This is the hardest part of testing, where do you start? People often get
overwhelmed at the apparent enormity of the task of testing a whole module.
-The best place to start is at the beginning. C<Date::ICal> is an
+The best place to start is at the beginning. L<Date::ICal> is an
object-oriented module, and that means you start by making an object. Test
C<new()>.
ok 8 - year()
# Looks like you failed 1 tests of 8.
-Whoops, a failure! [4] C<Test::Simple> helpfully lets us know on what line the
+Whoops, a failure! [4] L<Test::Simple> helpfully lets us know on what line the
failure occurred, but not much else. We were supposed to get 17, but we
didn't. What did we get?? Dunno. You could re-run the test in the debugger
or throw in some print statements to find out.
-Instead, switch from L<Test::Simple> to L<Test::More>. C<Test::More>
-does everything C<Test::Simple> does, and more! In fact, C<Test::More> does
-things I<exactly> the way C<Test::Simple> does. You can literally swap
-C<Test::Simple> out and put C<Test::More> in its place. That's just what
+Instead, switch from L<Test::Simple> to L<Test::More>. L<Test::More>
+does everything L<Test::Simple> does, and more! In fact, L<Test::More> does
+things I<exactly> the way L<Test::Simple> does. You can literally swap
+L<Test::Simple> out and put L<Test::More> in its place. That's just what
we're going to do.
-C<Test::More> does more than C<Test::Simple>. The most important difference at
+L<Test::More> does more than L<Test::Simple>. The most important difference at
this point is it provides more informative ways to say "ok". Although you can
write almost any test with a generic C<ok()>, it can't tell you what went
wrong. The C<is()> function lets us declare that something is supposed to be
is( $ical->month, 10, ' month()' );
is( $ical->year, 1964, ' year()' );
-"Is C<$ical-E<gt>sec> 47?" "Is C<$ical-E<gt>min> 12?" With C<is()> in place,
+"Is C<< $ical->sec >> 47?" "Is C<< $ical->min >> 12?" With C<is()> in place,
you get more information:
1..8
ok 8 - year()
# Looks like you failed 1 tests of 8.
-Aha. C<$ical-E<gt>day> returned 16, but we expected 17. A
+Aha. C<< $ical->day >> returned 16, but we expected 17. A
quick check shows that the code is working fine, we made a mistake
when writing the tests. Change it to:
C<%ICal_Dates>. Now that it's less work to test with more dates, you'll
be inclined to just throw more in as you think of them.
Only problem is, every time we add to that we have to keep adjusting
-the C<use Test::More tests =E<gt> ##> line. That can rapidly get
+the L<< use Test::More tests => ## >> line. That can rapidly get
annoying. There are ways to make this work better.
First, we can calculate the plan dynamically using the C<plan()>
done_testing(); # reached the end safely
-If you don't specify a plan, C<Test::More> expects to see C<done_testing()>
+If you don't specify a plan, L<Test::More> expects to see C<done_testing()>
before your program exits. It will warn you if you forget it. You can give
C<done_testing()> an optional number of tests you expected to run, and if the
-number ran differs, C<Test::More> will give you another kind of warning.
+number ran differs, L<Test::More> will give you another kind of warning.
=head2 Informative names
A little bit of magic happens here. When running on anything but MacOS, all
the tests run normally. But when on MacOS, C<skip()> causes the entire
contents of the SKIP block to be jumped over. It never runs. Instead,
-C<skip()> prints special output that tells C<Test::Harness> that the tests have
+C<skip()> prints special output that tells L<Test::Harness> that the tests have
been skipped.
1..7
=head2 Todo tests
-While thumbing through the C<Date::ICal> man page, I came across this:
+While thumbing through the L<Date::ICal> man page, I came across this:
ical
# got: '20010822T201551Z'
# expected: '20201231Z'
-C<Test::More> doesn't say "Looks like you failed 1 tests of 1". That '#
-TODO' tells C<Test::Harness> "this is supposed to fail" and it treats a
+L<Test::More> doesn't say "Looks like you failed 1 tests of 1". That '#
+TODO' tells L<Test::Harness> "this is supposed to fail" and it treats a
failure as a successful test. You can write tests even before
you've fixed the underlying code.
-If a TODO test passes, C<Test::Harness> will report it "UNEXPECTEDLY
+If a TODO test passes, L<Test::Harness> will report it "UNEXPECTEDLY
SUCCEEDED". When that happens, remove the TODO block with C<local $TODO> and
turn it into a real test.
mode.
It's very simple to have your tests run under taint mode. Just throw
-a C<-T> into the C<#!> line. C<Test::Harness> will read the switches
+a C<-T> into the C<#!> line. L<Test::Harness> will read the switches
in C<#!> and use them to run your tests.
#!/usr/bin/perl -Tw
But what happens if your test program dies halfway through?! Since we
didn't say how many tests we're going to run, how can we know it
-failed? No problem, C<Test::More> employs some magic to catch that death
+failed? No problem, L<Test::More> employs some magic to catch that death
and turn the test into a failure, even if every test passed up to that
point.
#!/usr/bin/perl -w
+use Config; # To prevent conflict with some strawberry-portable versions
BEGIN {
if( $ENV{PERL_CORE} ) {
use strict;
use Test::Builder;
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ( '../lib', 'lib' );
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+use Test::Builder::NoOutput;
+
my $tb = Test::Builder->new;
$tb->ok( !eval { $tb->subtest() } );
$tb->ok( !eval { $tb->subtest("foo") } );
$tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ );
+$tb->subtest('Arg passing', sub {
+ my $foo = shift;
+ my $child = Test::Builder->new;
+ $child->is_eq($foo, 'foo');
+ $child->done_testing;
+ $child->finalize;
+}, 'foo');
+
$tb->done_testing();
# Assume interval timer granularity of $limit * 0.5 seconds. Too bold?
my $virt = Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL);
-ok defined $virt && abs($virt / 0.5) - 1 < $limit
- or diag "virt=" . (defined $virt ? $virt : 'undef');
+ok defined $virt && abs($virt / 0.5) - 1 < $limit;
note "getitimer: ", join(" ",
Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL));
Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL));
$virt = Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL);
-note "at end, i=$i";
-is($virt, 0, "time left should be zero");
+ok defined $virt && $virt == 0;
$SIG{VTALRM} = 'DEFAULT';
':override' => 'internal',
);
-our $VERSION = '1.27';
+our $VERSION = '1.29';
bootstrap Time::Piece $VERSION;
use strict;
use vars qw/@EXPORT @EXPORT_OK/;
-our $VERSION = '1.27';
+our $VERSION = '1.29';
use Exporter 5.57 'import';
if ($s >= ONE_HOUR) {
if ($s >= ONE_DAY) {
my $days = sprintf("%d", $s->days); # does a "floor"
- $str = $days . " days, ";
+ $str .= $days . " days, ";
$s -= ($days * ONE_DAY);
}
my $hours = sprintf("%d", $s->hours);
-use Test::More tests => 96;
+use Test::More tests => 95;
my $is_win32 = ($^O =~ /Win32/);
my $is_qnx = ($^O eq 'qnx');
my $is_vos = ($^O eq 'vos');
-BEGIN { use_ok('Time::Piece'); }
-ok(1);
+
+use Time::Piece;
+use Time::Seconds;
my $t = gmtime(951827696); # 2000-02-29T12:34:56
951827696
);
+my $s = Time::Seconds->new(-691050);
+is($s->pretty, 'minus 7 days, 23 hours, 57 minutes, 30 seconds');
package experimental;
-$experimental::VERSION = '0.008';
+$experimental::VERSION = '0.010';
use strict;
use warnings;
use version ();
use Carp qw/croak carp/;
my %warnings = map { $_ => 1 } grep { /^experimental::/ } keys %warnings::Offsets;
-my %features = map { $_ => 1 } keys %feature::feature;
+my %features = map { $_ => 1 } $] > 5.015006 ? keys %feature::feature : do {
+ my @features;
+ if ($] >= 5.010) {
+ push @features, qw/switch say state/;
+ push @features, 'unicode_strings' if $] > 5.011002;
+ }
+ @features;
+};
my %min_version = (
- 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'),
+ array_base => '5',
+ autoderef => '5.14.0',
+ current_sub => '5.16.0',
+ evalbytes => '5.16.0',
+ fc => '5.16.0',
+ lexical_topic => '5.10.0',
+ lexical_subs => '5.18.0',
+ postderef => '5.20.0',
+ postderef_qq => '5.20.0',
+ regex_sets => '5.18.0',
+ say => '5.10.0',
+ smartmatch => '5.10.0',
+ signatures => '5.20.0',
+ state => '5.10.0',
+ switch => '5.10.0',
+ unicode_eval => '5.16.0',
+ unicode_strings => '5.12.0',
);
+$_ = version->new($_) for values %min_version;
my %additional = (
postderef => ['postderef_qq'],
=head1 VERSION
-version 0.008
+version 0.010
=head1 SYNOPSIS
use experimental 'lexical_topic';
my $_ = 1;
is($_, 1, '$_ is 1');
+ 1;
END
}
else {
}
if ($] >= 5.010001) {
+ is (eval <<'END', 1, 'switch compiles') or diag $@;
+ use experimental 'switch';
+ sub bar { 1 };
+ given(1) {
+ when (\&bar) {
+ pass("bar matches 1");
+ }
+ default {
+ fail("bar matches 1");
+ }
+ }
+ 1;
+END
+}
+
+if ($] >= 5.010001) {
is (eval <<'END', 1, 'smartmatch compiles') or diag $@;
use experimental 'smartmatch';
sub bar { 1 };
is(1 ~~ \&bar, 1, "is 1");
+ 1;
END
}
use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
-$VERSION = 0.9908;
+$VERSION = 0.9909;
$CLASS = 'version';
# avoid using Exporter
use vars qw($VERSION $CLASS $STRICT $LAX);
-$VERSION = 0.9908;
+$VERSION = 0.9909;
#--------------------------------------------------------------------------#
# Version regexp components
use Config;
use vars qw($VERSION $CLASS @ISA $LAX $STRICT);
-$VERSION = 0.9908;
+$VERSION = 0.9909;
$CLASS = 'version::vpp';
require version::regex;
BEGIN {
(my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
require $coretests;
- use_ok('version::vpp', 0.9908);
+ use_ok('version::vpp', 0.9909);
}
BaseTests("version::vpp","new","qv");
BEGIN {
(my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
require $coretests;
- use_ok('version', 0.9908);
+ use_ok('version', 0.9909);
}
BaseTests("version","new","qv");
BEGIN {
(my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
require $coretests;
- use_ok("version", 0.9908);
+ use_ok("version", 0.9909);
# If we made it this far, we are ok.
}
# Don't want to use, because we need to make sure that the import doesn't
# fire just yet (some code does this to avoid importing qv() and delare()).
require_ok("version");
-is $version::VERSION, 0.9908, "Make sure we have the correct class";
+is $version::VERSION, 0.9909, "Make sure we have the correct class";
ok(!"main"->can("qv"), "We don't have the imported qv()");
ok(!"main"->can("declare"), "We don't have the imported declare()");
}
BEGIN {
- use version 0.9908;
+ use version 0.9909;
}
pass "Didn't get caught by the wrong DIE handler, which is a good thing";
use Test::More qw/no_plan/;
BEGIN {
- use_ok('version', 0.9908);
+ use_ok('version', 0.9909);
}
my $v1 = version->new('1.2');
use Config;
BEGIN {
- use_ok('version', 0.9908);
+ use_ok('version', 0.9909);
}
SKIP: {
#########################
use Test::More tests => 3;
-use_ok("version", 0.9908);
+use_ok("version", 0.9909);
# do strict lax tests in a sub to isolate a package to test importing
SKIP: {
#########################
use strict;
-use_ok("version", 0.9908);
+use_ok("version", 0.9909);
use Test::More;
BEGIN {
#define CvROOT(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_root_u.xcv_root
#define CvXSUB(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_root_u.xcv_xsub
#define CvXSUBANY(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_start_u.xcv_xsubany
-#define CvGV(sv) S_CvGV((const CV *)(sv))
+#define CvGV(sv) S_CvGV(aTHX_ (CV *)(sv))
#define CvGV_set(cv,gv) Perl_cvgv_set(aTHX_ cv, gv)
+#define CvHASGV(cv) cBOOL(SvANY(cv)->xcv_gv_u.xcv_gv)
#define CvFILE(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_file
#ifdef USE_ITHREADS
# define CvFILE_set_from_cop(sv, cop) \
#define CVf_AUTOLOAD 0x2000 /* SvPVX contains AUTOLOADed sub name */
#define CVf_HASEVAL 0x4000 /* contains string eval */
#define CVf_NAMED 0x8000 /* Has a name HEK */
+#define CVf_LEXICAL 0x10000 /* Omit package from name */
/* This symbol for optimised communication between toke.c and op.c: */
#define CVf_BUILTIN_ATTRS (CVf_METHOD|CVf_LVALUE)
#define CvNAMED_on(cv) (CvFLAGS(cv) |= CVf_NAMED)
#define CvNAMED_off(cv) (CvFLAGS(cv) &= ~CVf_NAMED)
+#define CvLEXICAL(cv) (CvFLAGS(cv) & CVf_LEXICAL)
+#define CvLEXICAL_on(cv) (CvFLAGS(cv) |= CVf_LEXICAL)
+#define CvLEXICAL_off(cv) (CvFLAGS(cv) &= ~CVf_LEXICAL)
+
/* Flags for newXS_flags */
#define XS_DYNAMIC_FILENAME 0x01 /* The filename isn't static */
-PERL_STATIC_INLINE GV *
-S_CvGV(const CV *sv)
-{
- return CvNAMED(sv)
- ? 0
- : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
-}
PERL_STATIC_INLINE HEK *
CvNAME_HEK(CV *sv)
{
typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *);
+#define CALL_CHECKER_REQUIRE_GV MGf_REQUIRE_GV
+
+#ifdef PERL_CORE
+# define CV_UNDEF_KEEP_NAME 1
+#endif
+
/*
* Local variables:
* c-indentation-style: bsd
use warnings;
use strict;
use vars qw($VERSION $AUTOLOAD);
-$VERSION = '0.96'; # remember to update version in POD!
+$VERSION = '0.97'; # remember to update version in POD!
# $DB::single=1;
my %symcache;
return $symcache{$pkg,$ref} if $symcache{$pkg,$ref};
$type ||= ref($ref);
no strict 'refs';
- foreach my $sym ( values %{$pkg."::"} ) {
+ my $symtab = \%{$pkg."::"};
+ for ( keys %$symtab ) { for my $sym ( $$symtab{$_} ) {
+ if (ref $sym && $sym == $ref) {
+ return $symcache{$pkg,$ref} = \*{"$pkg:\:$_"};
+ }
use strict;
next unless ref ( \$sym ) eq 'GLOB';
return $symcache{$pkg,$ref} = \$sym
if *{$sym}{$type} && *{$sym}{$type} == $ref;
- }
+ }}
}
my %validtype = (
=head1 VERSION
-This document describes version 0.96 of Attribute::Handlers.
+This document describes version 0.97 of Attribute::Handlers.
=head1 SYNOPSIS
package Data::Dumper;
BEGIN {
- $VERSION = '2.152'; # Don't forget to set version and release
+ $VERSION = '2.154'; # Don't forget to set version and release
} # date in POD below!
#$| = 1;
$Sortkeys = 0 unless defined $Sortkeys;
$Deparse = 0 unless defined $Deparse;
$Sparseseen = 0 unless defined $Sparseseen;
+$Maxrecurse = 1000 unless defined $Maxrecurse;
#
# expects an arrayref of values to be dumped.
'bless' => $Bless, # keyword to use for "bless"
# expdepth => $Expdepth, # cutoff depth for explicit dumping
maxdepth => $Maxdepth, # depth beyond which we give up
+ maxrecurse => $Maxrecurse, # depth beyond which we abort
useperl => $Useperl, # use the pure Perl implementation
sortkeys => $Sortkeys, # flag or filter for sorting hash keys
deparse => $Deparse, # use B::Deparse for coderefs
return qq['$val'];
}
+ # avoid recursing infinitely [perl #122111]
+ if ($s->{maxrecurse} > 0
+ and $s->{level} >= $s->{maxrecurse}) {
+ die "Recursion limit of $s->{maxrecurse} exceeded";
+ }
+
# we have a blessed ref
my ($blesspad);
if ($realpack and !$no_bless) {
defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'};
}
+sub Maxrecurse {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'maxrecurse'} = $v), return $s) : $s->{'maxrecurse'};
+}
+
sub Useperl {
my($s, $v) = @_;
defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'};
=item *
+$Data::Dumper::Maxrecurse I<or> $I<OBJ>->Maxrecurse(I<[NEWVAL]>)
+
+Can be set to a positive integer that specifies the depth beyond which
+recursion into a structure will throw an exception. This is intended
+as a security measure to prevent perl running out of stack space when
+dumping an excessively deep structure. Can be set to 0 to remove the
+limit. Default is 1000.
+
+=item *
+
$Data::Dumper::Useperl I<or> $I<OBJ>->Useperl(I<[NEWVAL]>)
Can be set to a boolean value which controls whether the pure Perl
=head1 VERSION
-Version 2.153 (June 5 2014)
+Version 2.154 (September 18 2014)
=head1 SEE ALSO
SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair,
SV *freezer, SV *toaster,
I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
- I32 maxdepth, SV *sortkeys, int use_sparse_seen_hash, I32 useqq);
+ I32 maxdepth, SV *sortkeys, int use_sparse_seen_hash, I32 useqq, IV maxrecurse);
#ifndef HvNAME_get
#define HvNAME_get HvNAME
AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys,
- int use_sparse_seen_hash, I32 useqq)
+ int use_sparse_seen_hash, I32 useqq, IV maxrecurse)
{
char tmpbuf[128];
Size_t i;
return 1;
}
+ if (maxrecurse > 0 && *levelp >= maxrecurse) {
+ croak("Recursion limit of %" IVdf " exceeded", maxrecurse);
+ }
+
if (realpack && !no_bless) { /* we have a blessed ref */
STRLEN blesslen;
const char * const blessstr = SvPV(bless, blesslen);
DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
postav, levelp, indent, pad, xpad, apad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth, sortkeys, use_sparse_seen_hash, useqq);
+ maxdepth, sortkeys, use_sparse_seen_hash, useqq,
+ maxrecurse);
sv_catpvs(retval, ")}");
} /* plain */
else {
DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
postav, levelp, indent, pad, xpad, apad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth, sortkeys, use_sparse_seen_hash, useqq);
+ maxdepth, sortkeys, use_sparse_seen_hash, useqq,
+ maxrecurse);
}
SvREFCNT_dec(namesv);
}
DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
postav, levelp, indent, pad, xpad, apad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth, sortkeys, use_sparse_seen_hash, useqq);
+ maxdepth, sortkeys, use_sparse_seen_hash, useqq,
+ maxrecurse);
SvREFCNT_dec(namesv);
}
else if (realtype == SVt_PVAV) {
DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
levelp, indent, pad, xpad, apad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth, sortkeys, use_sparse_seen_hash, useqq);
+ maxdepth, sortkeys, use_sparse_seen_hash,
+ useqq, maxrecurse);
if (ix < ixmax)
sv_catpvs(retval, ",");
}
DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
postav, levelp, indent, pad, xpad, newapad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys, bless,
- maxdepth, sortkeys, use_sparse_seen_hash, useqq);
+ maxdepth, sortkeys, use_sparse_seen_hash, useqq,
+ maxrecurse);
SvREFCNT_dec(sname);
Safefree(nkey_buffer);
if (indent >= 2)
seenhv, postav, &nlevel, indent, pad, xpad,
newapad, sep, pair, freezer, toaster, purity,
deepcopy, quotekeys, bless, maxdepth,
- sortkeys, use_sparse_seen_hash, useqq);
+ sortkeys, use_sparse_seen_hash, useqq,
+ maxrecurse);
SvREFCNT_dec(e);
}
}
SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
SV *freezer, *toaster, *bless, *sortkeys;
I32 purity, deepcopy, quotekeys, maxdepth = 0;
+ IV maxrecurse = 1000;
char tmpbuf[1024];
I32 gimme = GIMME;
int use_sparse_seen_hash = 0;
bless = *svp;
if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
maxdepth = SvIV(*svp);
+ if ((svp = hv_fetch(hv, "maxrecurse", 10, FALSE)))
+ maxrecurse = SvIV(*svp);
if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
sortkeys = *svp;
if (! SvTRUE(sortkeys))
DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
postav, &level, indent, pad, xpad, newapad, sep, pair,
freezer, toaster, purity, deepcopy, quotekeys,
- bless, maxdepth, sortkeys, use_sparse_seen_hash, useqq);
+ bless, maxdepth, sortkeys, use_sparse_seen_hash,
+ useqq, maxrecurse);
SPAGAIN;
if (indent >= 2 && !terse)
--- /dev/null
+#!perl
+
+# Test the Maxrecurse option
+
+use strict;
+use Test::More tests => 32;
+use Data::Dumper;
+
+SKIP: {
+ skip "no XS available", 16
+ if $Data::Dumper::Useperl;
+ local $Data::Dumper::Useperl = 1;
+ test_recursion();
+}
+
+test_recursion();
+
+sub test_recursion {
+ my $pp = $Data::Dumper::Useperl ? "pure perl" : "XS";
+ $Data::Dumper::Purity = 1; # make sure this has no effect
+ $Data::Dumper::Indent = 0;
+ $Data::Dumper::Maxrecurse = 1;
+ is(eval { Dumper([]) }, '$VAR1 = [];', "$pp: maxrecurse 1, []");
+ is(eval { Dumper([[]]) }, undef, "$pp: maxrecurse 1, [[]]");
+ ok($@, "exception thrown");
+ is(eval { Dumper({}) }, '$VAR1 = {};', "$pp: maxrecurse 1, {}");
+ is(eval { Dumper({ a => 1 }) }, q($VAR1 = {'a' => 1};),
+ "$pp: maxrecurse 1, { a => 1 }");
+ is(eval { Dumper({ a => {} }) }, undef, "$pp: maxrecurse 1, { a => {} }");
+ ok($@, "exception thrown");
+ is(eval { Dumper(\1) }, "\$VAR1 = \\1;", "$pp: maxrecurse 1, \\1");
+ is(eval { Dumper(\\1) }, undef, "$pp: maxrecurse 1, \\1");
+ ok($@, "exception thrown");
+ $Data::Dumper::Maxrecurse = 3;
+ is(eval { Dumper(\1) }, "\$VAR1 = \\1;", "$pp: maxrecurse 3, \\1");
+ is(eval { Dumper(\(my $s = {})) }, "\$VAR1 = \\{};", "$pp: maxrecurse 3, \\{}");
+ is(eval { Dumper(\(my $s = { a => [] })) }, "\$VAR1 = \\{'a' => []};",
+ "$pp: maxrecurse 3, \\{ a => [] }");
+ is(eval { Dumper(\(my $s = { a => [{}] })) }, undef,
+ "$pp: maxrecurse 3, \\{ a => [{}] }");
+ ok($@, "exception thrown");
+ $Data::Dumper::Maxrecurse = 0;
+ is(eval { Dumper([[[[[]]]]]) }, q($VAR1 = [[[[[]]]]];),
+ "$pp: check Maxrecurse doesn't set limit to 0 recursion");
+}
Revision history for Perl extension ExtUtils::CBuilder.
+0.280219 - 2014-09-01
+
+ Fixed:
+
+ - Fixed regression on Android (thanks to Brian Fraser)
+
+0.280218 - 2014-09-01
+
+ Fixed:
+
+ - Mispelled 'starup' key in BCC support was fixed. #79574
+ - Fixed the version in the PM file (thanks to Jim Keenan)
+
+0.280217 - 2014-08-22
+
+ Fixed:
+
+ - Quoted perl path for Windows support #98245 [Alberto Simões]
+
0.280216 - 2014-03-07
Added:
-# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.013.
+# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.020.
use strict;
use warnings;
-use ExtUtils::MakeMaker 6.30;
+use ExtUtils::MakeMaker ;
my %WriteMakefileArgs = (
"ABSTRACT" => "Compile and link C code for Perl modules",
"AUTHOR" => "Ken Williams <kwilliams\@cpan.org>, The Perl 5 Porters",
- "BUILD_REQUIRES" => {},
"CONFIGURE_REQUIRES" => {
- "ExtUtils::MakeMaker" => "6.30"
+ "ExtUtils::MakeMaker" => 0
},
"DISTNAME" => "ExtUtils-CBuilder",
"EXE_FILES" => [],
"TEST_REQUIRES" => {
"Test::More" => "0.47"
},
- "VERSION" => "0.280216",
+ "VERSION" => "0.280219",
"test" => {
"TESTS" => "t/*.t"
}
package ExtUtils::CBuilder;
-
+$ExtUtils::CBuilder::VERSION = '0.280219';
use File::Spec ();
use File::Path ();
use File::Basename ();
use Perl::OSType qw/os_type/;
-use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
-$VERSION = eval $VERSION;
+use vars qw(@ISA);
# We only use this once - don't waste a symbol table entry on it.
# More importantly, don't make it an inheritable method.
package ExtUtils::CBuilder::Base;
-
+$ExtUtils::CBuilder::Base::VERSION = '0.280219';
use strict;
use File::Spec;
use File::Basename;
use IPC::Cmd qw(can_run);
use File::Temp qw(tempfile);
-use vars qw($VERSION);
-$VERSION = '0.280217';
-
# More details about C/C++ compilers:
# http://developers.sun.com/sunstudio/documentation/product/compiler.jsp
# http://gcc.gnu.org/
package ExtUtils::CBuilder::Platform::Unix;
-
+$ExtUtils::CBuilder::Platform::Unix::VERSION = '0.280219';
use strict;
use ExtUtils::CBuilder::Base;
-use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+use vars qw(@ISA);
@ISA = qw(ExtUtils::CBuilder::Base);
sub link_executable {
package ExtUtils::CBuilder::Platform::VMS;
-
+$ExtUtils::CBuilder::Platform::VMS::VERSION = '0.280219';
use strict;
use ExtUtils::CBuilder::Base;
-use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+use vars qw(@ISA);
@ISA = qw(ExtUtils::CBuilder::Base);
use File::Spec::Functions qw(catfile catdir);
package ExtUtils::CBuilder::Platform::Windows;
-
+$ExtUtils::CBuilder::Platform::Windows::VERSION = '0.280219';
use strict;
use warnings;
use ExtUtils::CBuilder::Base;
use IO::File;
-use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+use vars qw(@ISA);
@ISA = qw(ExtUtils::CBuilder::Base);
=begin comment
package ExtUtils::CBuilder::Platform::Windows::BCC;
-
-use vars qw($VERSION);
-$VERSION = '0.280217';
-
+$ExtUtils::CBuilder::Platform::Windows::BCC::VERSION = '0.280219';
sub format_compiler_cmd {
my ($self, %spec) = @_;
}
push( @{$spec{startup}}, 'c0d32.obj' )
- unless ( $spec{starup} && @{$spec{startup}} );
+ unless ( $spec{startup} && @{$spec{startup}} );
%spec = $self->write_linker_script(%spec)
if $spec{use_scripts};
package ExtUtils::CBuilder::Platform::Windows::GCC;
-
-use vars qw($VERSION);
-$VERSION = '0.280217';
-
+$ExtUtils::CBuilder::Platform::Windows::GCC::VERSION = '0.280219';
sub format_compiler_cmd {
my ($self, %spec) = @_;
package ExtUtils::CBuilder::Platform::Windows::MSVC;
-
-use vars qw($VERSION);
-$VERSION = '0.280217';
-
+$ExtUtils::CBuilder::Platform::Windows::MSVC::VERSION = '0.280219';
sub arg_exec_file {
my ($self, $file) = @_;
return "/OUT:$file";
package ExtUtils::CBuilder::Platform::aix;
-
+$ExtUtils::CBuilder::Platform::aix::VERSION = '0.280219';
use strict;
use ExtUtils::CBuilder::Platform::Unix;
use File::Spec;
-use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+use vars qw(@ISA);
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
sub need_prelink { 1 }
package ExtUtils::CBuilder::Platform::android;
-
+$ExtUtils::CBuilder::Platform::android::VERSION = '0.280219';
use strict;
-use Config;
use File::Spec;
use ExtUtils::CBuilder::Platform::Unix;
-use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+use vars qw(@ISA);
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
# The Android linker will not recognize symbols from
package ExtUtils::CBuilder::Platform::cygwin;
-
+$ExtUtils::CBuilder::Platform::cygwin::VERSION = '0.280219';
use strict;
use File::Spec;
use ExtUtils::CBuilder::Platform::Unix;
-use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+use vars qw(@ISA);
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
# TODO: If a specific exe_file name is requested, if the exe created
package ExtUtils::CBuilder::Platform::darwin;
-
+$ExtUtils::CBuilder::Platform::darwin::VERSION = '0.280219';
use strict;
use ExtUtils::CBuilder::Platform::Unix;
-use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+use vars qw(@ISA);
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
sub compile {
package ExtUtils::CBuilder::Platform::dec_osf;
-
+$ExtUtils::CBuilder::Platform::dec_osf::VERSION = '0.280219';
use strict;
use ExtUtils::CBuilder::Platform::Unix;
use File::Spec;
-use vars qw($VERSION @ISA);
+use vars qw(@ISA);
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
-$VERSION = '0.280217';
sub link_executable {
my $self = shift;
package ExtUtils::CBuilder::Platform::os2;
-
+$ExtUtils::CBuilder::Platform::os2::VERSION = '0.280219';
use strict;
use ExtUtils::CBuilder::Platform::Unix;
-use vars qw($VERSION @ISA);
-$VERSION = '0.280217';
+use vars qw(@ISA);
@ISA = qw(ExtUtils::CBuilder::Platform::Unix);
sub need_prelink { 1 }
my $perl;
BEGIN {
$perl = File::Spec->rel2abs($^X);
+ $perl = qq{"$perl"}; # So it doesn't fail when there are spaces.
}
use strict;
written in the XS language and is the core component of the Perl
extension interface.
+Before writing XS, read the L</CAVEATS> section below.
+
An B<XSUB> forms the basic unit of the XS interface. After compilation
by the B<xsubpp> compiler, each XSUB amounts to a C function definition
which will provide the glue between Perl calling conventions and C
print "time = $a\n";
print "netconf = $netconf\n";
+=head1 CAVEATS
+
+XS code has full access to system calls including C library functions.
+It thus has the capability of interfering with things that the Perl core
+or other modules have set up, such as signal handlers or file handles.
+It could mess with the memory, or any number of harmful things. Don't.
+
+Some modules have an event loop, waiting for user-input. It is highly
+unlikely that two such modules would work adequately together in a
+single Perl application.
+
+In general, the perl interpreter views itself as the center of the
+universe as far as the Perl program goes. XS code is viewed as a
+help-mate, to accomplish things that perl doesn't do, or doesn't do fast
+enough, but always subservient to perl. The closer XS code adheres to
+this model, the less likely conflicts will occur.
+
+One area where there has been conflict is in regards to C locales. (See
+L<perllocale>.) perl, with one exception and unless told otherwise,
+sets up the underlying locale the program is running in to that passed
+into it from the environment. As of v5.20, this underlying locale is
+completely hidden from pure perl code outside the lexical scope of
+C<S<use locale>>; except a couple of function calls in the POSIX
+module of necessity use it. But the underlying locale, with that one
+exception is exposed to XS code, affecting all C library routines whose
+behavior is locale-dependent. The exception is the
+L<C<LC_NUMERIC>|perllocale/Category LC_NUMERIC: Numeric Formatting>
+locale category, and the reason it is an exception is that experience
+has shown that it can be problematic for XS code, whereas we have not
+had reports of problems with the
+L<other locale categories|perllocale/WHAT IS A LOCALE>. And the reason
+for this one category being problematic is that the character used as a
+decimal point can vary. Many European languages use a comma, whereas
+English, and hence Perl are expecting a dot (U+002E: FULL STOP). Many
+modules can handle only the radix character being a dot, and so perl
+attempts to make it so. Up through Perl v5.20, the attempt was merely
+to set C<LC_NUMERIC> upon startup to the C<"C"> locale. Any
+L<setlocale()|perllocale/The setlocale function> otherwise would change
+it; this caused some failures. Therefore, starting in v5.22, perl tries
+to keep C<LC_NUMERIC> always set to C<"C"> for XS code.
+
+To summarize, here's what to expect and how to handle locales in XS code:
+
+=over
+
+=item Non-locale-aware XS code
+
+Keep in mind that even if you think your code is not locale-aware, it
+may call a C library function that is. Hopefully the man page for such
+a function will indicate that dependency, but the documentation is
+imperfect.
+
+The current locale is exposed to XS code except possibly C<LC_NUMERIC>.
+There have not been reports of problems with these other categories.
+
+Up through v5.20, Perl initializes things on start-up so that
+C<LC_NUMERIC> is set to the "C" locale. But if any code anywhere
+changes it, it will stay changed. This means that your module can't
+count on C<LC_NUMERIC> being something in particular, and you can't
+expect floating point numbers (including version strings) to have dots
+in them. If you don't allow for a non-dot, your code could break if
+anyone anywhere changes the locale. For this reason, v5.22 is changing
+the behavior so that Perl tries to keep C<LC_NUMERIC> in the "C" locale
+except around the operations internally where it should be something
+else. Misbehaving XS code will always be able to change the locale
+anyway, but the most common instance of this is checked for and
+handled.
+
+=item Locale-aware XS code
+
+If the locale from the user's environment is desired, there should be no
+need for XS code to set the locale except for C<LC_NUMERIC>, as perl has
+already set it up. XS code should avoid changing the locale, as it can
+adversely affect other, unrelated, code and may not be thread safe.
+However, some alien libraries that may be called do set it, such as
+C<Gtk>. This can cause problems for the perl core and other modules.
+Starting in v5.20.1, calling the function
+L<sync_locale()|perlapi/sync_locale> from XS should be sufficient to
+avoid most of these problems. Prior to this, you need a pure Perl
+segment that does this:
+
+ POSIX::setlocale(LC_ALL, POSIX::setlocale(LC_ALL));
+
+Macros are provided for XS code to temporarily change to use the
+underlying C<LC_NUMERIC> locale when necessary. An API is being
+developed for this, but has not yet been nailed down, but will be during
+the course of v5.21. Send email to L<mailto:perl5-porters@perl.org> for
+guidance.
+
+=back
=head1 XS VERSION
use strict;
use warnings;
-our $VERSION = "1.33";
+our $VERSION = "1.34";
XSLoader::load 'IO', $VERSION;
sub import {
# define dVAR dNOOP
#endif
+#ifndef OP_SIBLING
+# define OP_SIBLING(o) (o)->op_sibling
+#endif
+
static int not_here(const char *s) __attribute__noreturn__;
static int
not_here(const char *s)
require strict; import strict;
}
-use Test;
-
-BEGIN { plan tests => 12 }
+use Test::More tests => 12;
use IO::File;
my $io = IO::File->new($File) or die $!;
<F> for (1 .. 10);
-ok(lineno($io), "10 0 10");
+is(lineno($io), "10 0 10");
$io->getline for (1 .. 5);
-ok(lineno($io), "5 5 5");
+is(lineno($io), "5 5 5");
<F>;
-ok(lineno($io), "11 5 11");
+is(lineno($io), "11 5 11");
$io->getline;
-ok(lineno($io), "6 6 6");
+is(lineno($io), "6 6 6");
$t = tell F; # tell F; provokes a warning
-ok(lineno($io), "11 6 11");
+is(lineno($io), "11 6 11");
<F>;
-ok(lineno($io), "12 6 12");
+is(lineno($io), "12 6 12");
select F;
-ok(lineno($io), "12 6 12");
+is(lineno($io), "12 6 12");
<F> for (1 .. 10);
-ok(lineno($io), "22 6 22");
+is(lineno($io), "22 6 22");
$io->getline for (1 .. 5);
-ok(lineno($io), "11 11 11");
+is(lineno($io), "11 11 11");
$t = tell F;
# We used to have problems here before local $. worked.
# input_line_number() used to use select and tell. When we did the
-# same, that mechanism broke. It should work now.
-ok(lineno($io), "22 11 22");
+# same, that mechanism brise. It should work now.
+is(lineno($io), "22 11 22");
{
local $.;
$io->getline for (1 .. 5);
- ok(lineno($io), "16 16 16");
+ is(lineno($io), "16 16 16");
}
-ok(lineno($io), "22 16 22");
+is(lineno($io), "22 16 22");
# _a : accuracy
# _p : precision
-$VERSION = '1.9996';
+$VERSION = '1.9997';
require 5.006002;
require Exporter;
my $class = "Math::BigInt";
use 5.006002;
-$VERSION = '1.9996';
+$VERSION = '1.9997';
@ISA = qw(Exporter);
@EXPORT_OK = qw(objectify bgcd blcm);
Examples for rounding:
use Math::BigFloat;
- use Test;
+ use Test::More;
$x = Math::BigFloat->new(123.4567);
$y = Math::BigFloat->new(123.456789);
Math::BigFloat->accuracy(4); # no more A than 4
- ok ($x->copy()->fround(),123.4); # even rounding
+ is ($x->copy()->fround(),123.4); # even rounding
print $x->copy()->fround(),"\n"; # 123.4
Math::BigFloat->round_mode('odd'); # round to odd
print $x->copy()->fround(),"\n"; # 123.5
Both C<bstr()> and C<bsstr()> as well as automated stringify via overload now
drop the leading '+'. The old code would return '+3', the new returns '3'.
This is to be consistent with Perl and to make C<cmp> (especially with
-overloading) to work as you expect. It also solves problems with C<Test.pm>,
-because its C<ok()> uses 'eq' internally.
+overloading) to work as you expect. It also solves problems with C<Test.pm>
+and L<Test::More>, which stringify arguments before comparing them.
Mark Biggar said, when asked about to drop the '+' altogether, or make only
C<cmp> work:
So, the following examples will now work all as expected:
- use Test;
- BEGIN { plan tests => 1 }
+ use Test::More tests => 1;
use Math::BigInt;
my $x = new Math::BigInt 3*3;
my $y = new Math::BigInt 3*3;
- ok ($x,3*3);
+ is ($x,3*3, 'multiplication');
print "$x eq 9" if $x eq $y;
print "$x eq 9" if $x eq '9';
print "$x eq 9" if $x eq 3*3;
as 1e+308. If in doubt, convert both arguments to Math::BigInt before
comparing them as strings:
- use Test;
- BEGIN { plan tests => 3 }
+ use Test::More tests => 3;
use Math::BigInt;
$x = Math::BigInt->new('1e56'); $y = 1e56;
- ok ($x,$y); # will fail
- ok ($x->bsstr(),$y); # okay
+ is ($x,$y); # will fail
+ is ($x->bsstr(),$y); # okay
$y = Math::BigInt->new($y);
- ok ($x,$y); # okay
+ is ($x,$y); # okay
Alternatively, simply use C<< <=> >> for comparisons, this will get it
always right. There is not yet a way to get a number automatically represented
use strict;
# use warnings; # do not use warnings for older Perls
-our $VERSION = '1.9996';
+our $VERSION = '1.9997';
# 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.9996';
+$VERSION = '1.9997';
package Math::BigInt;
+5.20140920
+ - Updated for v5.21.4
+
+5.20140914
+ - Updated for v5.20.1
+
5.021003
- Prepared for v5.21.3
%bug_tracker %deprecated %delta/;
use Module::CoreList::TieHashDelta;
use version;
-$VERSION = '5.021003';
+$VERSION = '5.20140920';
my $dumpinc = 0;
sub import {
5.021001 => '2014-06-20',
5.021002 => '2014-07-20',
5.021003 => '2014-08-20',
+ 5.020001 => '2014-09-14',
+ 5.021004 => '2014-09-20',
);
for my $version ( sort { $a <=> $b } keys %released ) {
removed => {
}
},
+ 5.020001 => {
+ delta_from => 5.020000,
+ changed => {
+ 'Config' => '5.020001',
+ 'Config::Perl::V' => '0.22',
+ 'Cwd' => '3.48',
+ 'Exporter' => '5.71',
+ 'Exporter::Heavy' => '5.71',
+ 'ExtUtils::CBuilder' => '0.280217',
+ 'ExtUtils::CBuilder::Base'=> '0.280217',
+ 'ExtUtils::CBuilder::Platform::Unix'=> '0.280217',
+ 'ExtUtils::CBuilder::Platform::VMS'=> '0.280217',
+ 'ExtUtils::CBuilder::Platform::Windows'=> '0.280217',
+ 'ExtUtils::CBuilder::Platform::Windows::BCC'=> '0.280217',
+ 'ExtUtils::CBuilder::Platform::Windows::GCC'=> '0.280217',
+ 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> '0.280217',
+ 'ExtUtils::CBuilder::Platform::aix'=> '0.280217',
+ 'ExtUtils::CBuilder::Platform::android'=> '0.280217',
+ 'ExtUtils::CBuilder::Platform::cygwin'=> '0.280217',
+ 'ExtUtils::CBuilder::Platform::darwin'=> '0.280217',
+ 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.280217',
+ 'ExtUtils::CBuilder::Platform::os2'=> '0.280217',
+ 'File::Copy' => '2.30',
+ 'File::Spec' => '3.48',
+ 'File::Spec::Cygwin' => '3.48',
+ 'File::Spec::Epoc' => '3.48',
+ 'File::Spec::Functions' => '3.48',
+ 'File::Spec::Mac' => '3.48',
+ 'File::Spec::OS2' => '3.48',
+ 'File::Spec::Unix' => '3.48',
+ 'File::Spec::VMS' => '3.48',
+ 'File::Spec::Win32' => '3.48',
+ 'Module::CoreList' => '5.020001',
+ 'Module::CoreList::TieHashDelta'=> '5.020001',
+ 'Module::CoreList::Utils'=> '5.020001',
+ 'PerlIO::via' => '0.15',
+ 'Unicode::UCD' => '0.58',
+ 'XS::APItest' => '0.60_01',
+ 'utf8' => '1.13_01',
+ 'version' => '0.9909',
+ 'version::regex' => '0.9909',
+ 'version::vpp' => '0.9909',
+ },
+ removed => {
+ }
+ },
+ 5.021004 => {
+ delta_from => 5.021003,
+ changed => {
+ 'App::Prove' => '3.33',
+ 'App::Prove::State' => '3.33',
+ 'App::Prove::State::Result'=> '3.33',
+ 'App::Prove::State::Result::Test'=> '3.33',
+ 'Archive::Tar' => '2.02',
+ 'Archive::Tar::Constant'=> '2.02',
+ 'Archive::Tar::File' => '2.02',
+ 'Attribute::Handlers' => '0.97',
+ 'B' => '1.51',
+ 'B::Concise' => '0.993',
+ 'B::Deparse' => '1.28',
+ 'B::Op_private' => '5.021004',
+ 'CPAN::Meta::Requirements'=> '2.128',
+ 'Config' => '5.021004',
+ 'Cwd' => '3.50',
+ 'Data::Dumper' => '2.154',
+ 'ExtUtils::CBuilder' => '0.280219',
+ 'ExtUtils::CBuilder::Base'=> '0.280219',
+ 'ExtUtils::CBuilder::Platform::Unix'=> '0.280219',
+ 'ExtUtils::CBuilder::Platform::VMS'=> '0.280219',
+ 'ExtUtils::CBuilder::Platform::Windows'=> '0.280219',
+ 'ExtUtils::CBuilder::Platform::Windows::BCC'=> '0.280219',
+ 'ExtUtils::CBuilder::Platform::Windows::GCC'=> '0.280219',
+ 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> '0.280219',
+ 'ExtUtils::CBuilder::Platform::aix'=> '0.280219',
+ 'ExtUtils::CBuilder::Platform::android'=> '0.280219',
+ 'ExtUtils::CBuilder::Platform::cygwin'=> '0.280219',
+ 'ExtUtils::CBuilder::Platform::darwin'=> '0.280219',
+ 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.280219',
+ 'ExtUtils::CBuilder::Platform::os2'=> '0.280219',
+ 'ExtUtils::Install' => '2.04',
+ 'ExtUtils::Installed' => '2.04',
+ 'ExtUtils::Liblist::Kid'=> '6.98_01',
+ 'ExtUtils::Manifest' => '1.68',
+ 'ExtUtils::Packlist' => '2.04',
+ 'File::Find' => '1.28',
+ 'File::Spec' => '3.50',
+ 'File::Spec::Cygwin' => '3.50',
+ 'File::Spec::Epoc' => '3.50',
+ 'File::Spec::Functions' => '3.50',
+ 'File::Spec::Mac' => '3.50',
+ 'File::Spec::OS2' => '3.50',
+ 'File::Spec::Unix' => '3.50',
+ 'File::Spec::VMS' => '3.50',
+ 'File::Spec::Win32' => '3.50',
+ 'Getopt::Std' => '1.11',
+ 'HTTP::Tiny' => '0.049',
+ 'IO' => '1.34',
+ 'IO::Socket::IP' => '0.32',
+ 'List::Util' => '1.41',
+ 'List::Util::XS' => '1.41',
+ 'Locale::Codes' => '3.32',
+ 'Locale::Codes::Constants'=> '3.32',
+ 'Locale::Codes::Country'=> '3.32',
+ 'Locale::Codes::Country_Codes'=> '3.32',
+ 'Locale::Codes::Country_Retired'=> '3.32',
+ 'Locale::Codes::Currency'=> '3.32',
+ 'Locale::Codes::Currency_Codes'=> '3.32',
+ 'Locale::Codes::Currency_Retired'=> '3.32',
+ 'Locale::Codes::LangExt'=> '3.32',
+ 'Locale::Codes::LangExt_Codes'=> '3.32',
+ 'Locale::Codes::LangExt_Retired'=> '3.32',
+ 'Locale::Codes::LangFam'=> '3.32',
+ 'Locale::Codes::LangFam_Codes'=> '3.32',
+ 'Locale::Codes::LangFam_Retired'=> '3.32',
+ 'Locale::Codes::LangVar'=> '3.32',
+ 'Locale::Codes::LangVar_Codes'=> '3.32',
+ 'Locale::Codes::LangVar_Retired'=> '3.32',
+ 'Locale::Codes::Language'=> '3.32',
+ 'Locale::Codes::Language_Codes'=> '3.32',
+ 'Locale::Codes::Language_Retired'=> '3.32',
+ 'Locale::Codes::Script' => '3.32',
+ 'Locale::Codes::Script_Codes'=> '3.32',
+ 'Locale::Codes::Script_Retired'=> '3.32',
+ 'Locale::Country' => '3.32',
+ 'Locale::Currency' => '3.32',
+ 'Locale::Language' => '3.32',
+ 'Locale::Script' => '3.32',
+ 'Math::BigFloat' => '1.9997',
+ 'Math::BigInt' => '1.9997',
+ 'Math::BigInt::Calc' => '1.9997',
+ 'Math::BigInt::CalcEmu' => '1.9997',
+ 'Module::CoreList' => '5.20140920',
+ 'Module::CoreList::TieHashDelta'=> '5.20140920',
+ 'Module::CoreList::Utils'=> '5.20140920',
+ 'POSIX' => '1.43',
+ 'Pod::Perldoc' => '3.24',
+ 'Pod::Perldoc::BaseTo' => '3.24',
+ 'Pod::Perldoc::GetOptsOO'=> '3.24',
+ 'Pod::Perldoc::ToANSI' => '3.24',
+ 'Pod::Perldoc::ToChecker'=> '3.24',
+ 'Pod::Perldoc::ToMan' => '3.24',
+ 'Pod::Perldoc::ToNroff' => '3.24',
+ 'Pod::Perldoc::ToPod' => '3.24',
+ 'Pod::Perldoc::ToRtf' => '3.24',
+ 'Pod::Perldoc::ToTerm' => '3.24',
+ 'Pod::Perldoc::ToText' => '3.24',
+ 'Pod::Perldoc::ToTk' => '3.24',
+ 'Pod::Perldoc::ToXml' => '3.24',
+ 'Scalar::Util' => '1.41',
+ 'Sub::Util' => '1.41',
+ 'TAP::Base' => '3.33',
+ 'TAP::Formatter::Base' => '3.33',
+ 'TAP::Formatter::Color' => '3.33',
+ 'TAP::Formatter::Console'=> '3.33',
+ 'TAP::Formatter::Console::ParallelSession'=> '3.33',
+ 'TAP::Formatter::Console::Session'=> '3.33',
+ 'TAP::Formatter::File' => '3.33',
+ 'TAP::Formatter::File::Session'=> '3.33',
+ 'TAP::Formatter::Session'=> '3.33',
+ 'TAP::Harness' => '3.33',
+ 'TAP::Harness::Env' => '3.33',
+ 'TAP::Object' => '3.33',
+ 'TAP::Parser' => '3.33',
+ 'TAP::Parser::Aggregator'=> '3.33',
+ 'TAP::Parser::Grammar' => '3.33',
+ 'TAP::Parser::Iterator' => '3.33',
+ 'TAP::Parser::Iterator::Array'=> '3.33',
+ 'TAP::Parser::Iterator::Process'=> '3.33',
+ 'TAP::Parser::Iterator::Stream'=> '3.33',
+ 'TAP::Parser::IteratorFactory'=> '3.33',
+ 'TAP::Parser::Multiplexer'=> '3.33',
+ 'TAP::Parser::Result' => '3.33',
+ 'TAP::Parser::Result::Bailout'=> '3.33',
+ 'TAP::Parser::Result::Comment'=> '3.33',
+ 'TAP::Parser::Result::Plan'=> '3.33',
+ 'TAP::Parser::Result::Pragma'=> '3.33',
+ 'TAP::Parser::Result::Test'=> '3.33',
+ 'TAP::Parser::Result::Unknown'=> '3.33',
+ 'TAP::Parser::Result::Version'=> '3.33',
+ 'TAP::Parser::Result::YAML'=> '3.33',
+ 'TAP::Parser::ResultFactory'=> '3.33',
+ 'TAP::Parser::Scheduler'=> '3.33',
+ 'TAP::Parser::Scheduler::Job'=> '3.33',
+ 'TAP::Parser::Scheduler::Spinner'=> '3.33',
+ 'TAP::Parser::Source' => '3.33',
+ 'TAP::Parser::SourceHandler'=> '3.33',
+ 'TAP::Parser::SourceHandler::Executable'=> '3.33',
+ 'TAP::Parser::SourceHandler::File'=> '3.33',
+ 'TAP::Parser::SourceHandler::Handle'=> '3.33',
+ 'TAP::Parser::SourceHandler::Perl'=> '3.33',
+ 'TAP::Parser::SourceHandler::RawTAP'=> '3.33',
+ 'TAP::Parser::YAMLish::Reader'=> '3.33',
+ 'TAP::Parser::YAMLish::Writer'=> '3.33',
+ 'Term::ReadLine' => '1.15',
+ 'Test::Builder' => '1.001006',
+ 'Test::Builder::Module' => '1.001006',
+ 'Test::Builder::Tester' => '1.24',
+ 'Test::Builder::Tester::Color'=> '1.24',
+ 'Test::Harness' => '3.33',
+ 'Test::More' => '1.001006',
+ 'Test::Simple' => '1.001006',
+ 'Time::Piece' => '1.29',
+ 'Time::Seconds' => '1.29',
+ 'XS::APItest' => '0.64',
+ '_charnames' => '1.42',
+ 'attributes' => '0.23',
+ 'bigint' => '0.37',
+ 'bignum' => '0.38',
+ 'bigrat' => '0.37',
+ 'constant' => '1.32',
+ 'experimental' => '0.010',
+ 'overload' => '1.23',
+ 'threads' => '1.96',
+ 'version' => '0.9909',
+ 'version::regex' => '0.9909',
+ 'version::vpp' => '0.9909',
+ },
+ removed => {
+ }
+ },
);
sub is_core
removed => {
}
},
+ 5.020001 => {
+ delta_from => 5.020000,
+ changed => {
+ },
+ removed => {
+ }
+ },
+ 5.021004 => {
+ delta_from => 5.021003,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
for my $version (sort { $a <=> $b } keys %deprecated) {
'Pod::Usage' => 'cpan',
'Scalar::Util' => 'cpan',
'Socket' => 'cpan',
+ 'Sub::Util' => 'cpan',
'Sys::Syslog' => 'cpan',
'Sys::Syslog::Win32' => 'cpan',
'TAP::Base' => 'cpan',
'ExtUtils::Constant::ProxySubs'=> undef,
'ExtUtils::Constant::Utils'=> undef,
'ExtUtils::Constant::XS'=> undef,
- 'ExtUtils::Install' => 'http://rt.perl.org/rt3/',
- 'ExtUtils::Installed' => 'http://rt.perl.org/rt3/',
+ 'ExtUtils::Install' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-Install',
+ 'ExtUtils::Installed' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-Install',
'ExtUtils::Liblist' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker',
'ExtUtils::Liblist::Kid'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker',
'ExtUtils::MM' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker',
'ExtUtils::MY' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker',
'ExtUtils::MakeMaker' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker',
'ExtUtils::MakeMaker::Config'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker',
- 'ExtUtils::Manifest' => 'http://rt.perl.org/rt3/',
+ 'ExtUtils::Manifest' => 'http://github.com/Perl-Toolchain-Gang/ExtUtils-Manifest/issues',
'ExtUtils::Mkbootstrap' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker',
'ExtUtils::Mksymlists' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker',
- 'ExtUtils::Packlist' => 'http://rt.perl.org/rt3/',
+ 'ExtUtils::Packlist' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-Install',
'ExtUtils::testlib' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker',
'Fatal' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie',
'File::Fetch' => undef,
'Pod::Usage' => undef,
'Scalar::Util' => undef,
'Socket' => undef,
+ 'Sub::Util' => undef,
'Sys::Syslog' => undef,
'Sys::Syslog::Win32' => undef,
'TAP::Base' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Test-Harness',
'Test' => undef,
'Test::Builder' => 'http://github.com/Test-More/test-more/issues/',
'Test::Builder::Module' => 'http://github.com/Test-More/test-more/issues/',
- 'Test::Builder::Tester' => 'http://github.com/schwern/test-more/issues',
- 'Test::Builder::Tester::Color'=> 'http://github.com/schwern/test-more/issues',
+ 'Test::Builder::Tester' => 'http://github.com/Test-More/test-more/issues/',
+ 'Test::Builder::Tester::Color'=> 'http://github.com/Test-More/test-more/issues/',
'Test::Harness' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Test-Harness',
'Test::More' => 'http://github.com/Test-More/test-more/issues/',
'Test::Simple' => 'http://github.com/Test-More/test-more/issues/',
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, 5.21.1, 5.21.2 and 5.21.3 releases of perl.
+5.19.9, 5.19.10, 5.19.11, 5.20.0, 5.21.0, 5.21.1, 5.21.2, 5.21.3, 5.20.1
+and 5.21.4 releases of perl.
=head1 HISTORY
use strict;
use vars qw($VERSION);
-$VERSION = '5.021003';
+$VERSION = '5.20140920';
sub TIEHASH {
my ($class, $changed, $removed, $parent) = @_;
use Module::CoreList;
use Module::CoreList::TieHashDelta;
-$VERSION = '5.021003';
+$VERSION = '5.20140920';
sub utilities {
my $perl = shift;
removed => {
}
},
+ 5.020001 => {
+ delta_from => 5.02,
+ changed => {
+ },
+ removed => {
+ }
+ },
+ 5.021004 => {
+ delta_from => 5.021003,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
for my $version (sort { $a <=> $b } keys %delta) {
+++ /dev/null
-#!perl -w
-use strict;
-use Test::More;
-
-plan skip_all => 'This is perl core-only test' unless $ENV{PERL_CORE};
-plan skip_all => 'Special case v5.21.1 because rjbs' if sprintf("v%vd", $^V) eq 'v5.21.1';
-
-my @modules = qw[
- Module::CoreList
- Module::CoreList::Utils
- Module::CoreList::TieHashDelta
-];
-
-plan tests => scalar @modules;
-
-foreach my $mod ( @modules ) {
- eval "require $mod";
- my $vers = eval $mod->VERSION;
- ok( !( $vers < $] || $vers > $] ), "$mod version should match perl version in core" )
- or diag("$mod $vers doesn't match $]");
-}
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-$VERSION = '3.49';
+$VERSION = '3.50';
my $xs_version = $VERSION;
$VERSION =~ tr/_//;
# If loading the XS stuff doesn't work, we can fall back to pure perl
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
+ #"Cwd object version 3.48 does not match bootstrap parameter 3.50
#at lib/DynaLoader.pm line 216." by having this eval
if ( $] >= 5.006 ) {
require XSLoader;
symlink[slen] = '/';
symlink[slen + 1] = 0;
}
- left_len = my_strlcat(symlink, left, sizeof(left));
+ left_len = my_strlcat(symlink, left, sizeof(symlink));
if (left_len >= sizeof(left)) {
errno = ENAMETOOLONG;
return (NULL);
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = '3.49';
+$VERSION = '3.50';
$VERSION =~ tr/_//;
my %module = (MacOS => 'Mac',
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.49';
+$VERSION = '3.50';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use strict;
use vars qw($VERSION @ISA);
-$VERSION = '3.49';
+$VERSION = '3.50';
$VERSION =~ tr/_//;
require File::Spec::Unix;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-$VERSION = '3.49';
+$VERSION = '3.50';
$VERSION =~ tr/_//;
require Exporter;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.49';
+$VERSION = '3.50';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.49';
+$VERSION = '3.50';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use strict;
use vars qw($VERSION);
-$VERSION = '3.49';
+$VERSION = '3.50';
my $xs_version = $VERSION;
$VERSION =~ tr/_//;
#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
+ #"Cwd object version 3.48 does not match bootstrap parameter 3.50
#at lib/DynaLoader.pm line 216." by having this eval
if ( $] >= 5.006 ) {
require XSLoader;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.49';
+$VERSION = '3.50';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.49';
+$VERSION = '3.50';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
getlogin getlogin
syscall syscall
lock SKIP
-threadsv SKIP
setstate SKIP
method_named $x->y()
dor $x // $y
my $console;
my $consoleOUT;
- if (-e "/dev/tty" and $^O ne 'MSWin32') {
+ if ($^O ne 'MSWin32' and -e "/dev/tty") {
$console = "/dev/tty";
- } elsif (-e "con" or $^O eq 'MSWin32' or $^O eq 'msys') {
+ } elsif ($^O eq 'MSWin32' or $^O eq 'msys' or -e "con") {
$console = 'CONIN$';
$consoleOUT = 'CONOUT$';
} elsif ($^O eq 'VMS') {
package Term::ReadLine; # So late to allow the above code be defined?
-our $VERSION = '1.14';
+our $VERSION = '1.15';
my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
if ($which) {
package bigint;
use 5.006;
-$VERSION = '0.36';
+$VERSION = '0.37';
use Exporter;
@ISA = qw( Exporter );
@EXPORT_OK = qw( PI e bpi bexp hex oct );
# see if we can find Math::BigInt::Lite
if (!defined $a && !defined $p) # rounding won't work to well
{
- eval 'require Math::BigInt::Lite;';
- if ($@ eq '')
+ if (eval { require Math::BigInt::Lite; 1 })
{
@import = ( ); # :constant in Lite, not MBI
Math::BigInt::Lite->import( ':constant' );
package bignum;
use 5.006;
-$VERSION = '0.37';
+$VERSION = '0.38';
use Exporter;
@ISA = qw( bigint );
@EXPORT_OK = qw( PI e bexp bpi hex oct );
# see if we can find Math::BigInt::Lite
if (!defined $a && !defined $p) # rounding won't work to well
{
- eval 'require Math::BigInt::Lite;';
- if ($@ eq '')
+ if (eval { require Math::BigInt::Lite; 1 })
{
@import = ( ); # :constant in Lite, not MBI
Math::BigInt::Lite->import( ':constant' );
package bigrat;
use 5.006;
-$VERSION = '0.36';
+$VERSION = '0.37';
require Exporter;
@ISA = qw( bigint );
@EXPORT_OK = qw( PI e bpi bexp hex oct );
# see if we can find Math::BigInt::Lite
if (!defined $a && !defined $p) # rounding won't work to well
{
- eval 'require Math::BigInt::Lite;';
- if ($@ eq '')
+ if (eval { require Math::BigInt::Lite; 1 })
{
@import = ( ); # :constant in Lite, not MBI
Math::BigInt::Lite->import( ':constant' );
use strict;
use Test::More;
-eval 'require Math::BigInt::Lite;';
-if ($@ eq '')
+if (eval { require Math::BigInt::Lite; 1 })
{
plan (tests => 1);
# can use Lite, so let bignum try it
use strict;
use Test::More;
-eval 'require Math::BigInt::Lite;';
-if ($@ eq '')
+if (eval { require Math::BigInt::Lite; 1 })
{
plan (tests => 1);
# can use Lite, so let bignum try it
*Carp::carp = sub { push @W, $_[0]; };
}
-my $rc = eval ('bignum->import( "l" => "foo" );');
+my $rc = eval { bignum->import( "l" => "foo" ) };
is ($@,''); # shouldn't die
is (scalar @W, 1, 'one warning');
like ($W[0], qr/fallback to Math::/, 'got fallback');
-$rc = eval ('bignum->import( "lib" => "foo" );');
+$rc = eval { bignum->import( "lib" => "foo" ) };
is ($@,''); # ditto
is (scalar @W, 2, 'two warnings');
like ($W[1], qr/fallback to Math::/, 'got fallback');
-$rc = eval ('bignum->import( "try" => "foo" );');
+$rc = eval { bignum->import( "try" => "foo" ) };
is ($@,''); # shouldn't die
-$rc = eval ('bignum->import( "try" => "foo" );');
+$rc = eval { bignum->import( "try" => "foo" ) };
is ($@,''); # ditto
-$rc = eval ('bignum->import( "foo" => "bar" );');
+$rc = eval { bignum->import( "foo" => "bar" ) };
like ($@, qr/^Unknown option foo/i, 'died'); # should die
-$rc = eval ('bignum->import( "only" => "bar" );');
+$rc = eval { bignum->import( "only" => "bar" ) };
like ($@, qr/fallback disallowed/i, 'died'); # should die
# test that options are only lowercase (don't see a reason why allow UPPER)
foreach (qw/L LIB Lib T Trace TRACE V Version VERSION/)
{
- $rc = eval ('bignum->import( "$_" => "bar" );');
+ $rc = eval { bignum->import( $_ => "bar" ) };
like ($@, qr/^Unknown option $_/i, 'died'); # should die
}
use warnings::register;
use vars qw($VERSION %declared);
-$VERSION = '1.31';
+$VERSION = '1.32';
#=======================================================================
BEGIN {
# We'd like to do use constant _CAN_PCS => $] > 5.009002
# but that's a bit tricky before we load the constant module :-)
- # By doing this, we save 1 run time check for *every* call to import.
+ # By doing this, we save several run time checks for *every* call
+ # to import.
my $const = $] > 5.009002;
my $downgrade = $] < 5.015004; # && $] >= 5.008
my $constarray = exists &_make_const;
return unless @_; # Ignore 'use constant;'
my $constants;
my $multiple = ref $_[0];
- my $pkg = caller;
+ my $caller = caller;
my $flush_mro;
my $symtab;
if (_CAN_PCS) {
no strict 'refs';
- $symtab = \%{$pkg . '::'};
+ $symtab = \%{$caller . '::'};
};
if ( $multiple ) {
}
foreach my $name ( keys %$constants ) {
+ my $pkg;
+ my $symtab = $symtab;
+ my $orig_name = $name;
+ if ($name =~ s/(.*)(?:::|')(?=.)//s) {
+ $pkg = $1;
+ if (_CAN_PCS && $pkg ne $caller) {
+ no strict 'refs';
+ $symtab = \%{$pkg . '::'};
+ }
+ }
+ else {
+ $pkg = $caller;
+ }
+
# Normal constant name
if ($name =~ $normal_constant_name and !$forbidden{$name}) {
# Everything is okay
my $full_name = "${pkg}::$name";
$declared{$full_name}++;
if ($multiple || @_ == 1) {
- my $scalar = $multiple ? $constants->{$name} : $_[0];
+ my $scalar = $multiple ? $constants->{$orig_name} : $_[0];
if (_DOWNGRADE) { # for 5.8 to 5.14
# Work around perl bug #31991: Sub names (actually glob
# The check in Perl_ck_rvconst knows that inlinable
# constants from cv_const_sv are read only. So we have to:
Internals::SvREADONLY($scalar, 1);
- if ($symtab && !exists $symtab->{$name}) {
+ if (!exists $symtab->{$name}) {
$symtab->{$name} = \$scalar;
- ++$flush_mro;
+ ++$flush_mro->{$pkg};
}
else {
local $constant::{_dummy} = \$scalar;
if (_CAN_PCS_FOR_ARRAY) {
_make_const($list[$_]) for 0..$#list;
_make_const(@list);
- if ($symtab && !exists $symtab->{$name}) {
+ if (!exists $symtab->{$name}) {
$symtab->{$name} = \@list;
- $flush_mro++;
+ $flush_mro->{$pkg}++;
}
else {
local $constant::{_dummy} = \@list;
}
}
# Flush the cache exactly once if we make any direct symbol table changes.
- mro::method_changed_in($pkg) if _CAN_PCS && $flush_mro;
+ if (_CAN_PCS && $flush_mro) {
+ mro::method_changed_in($_) for keys %$flush_mro;
+ }
}
1;
ARRAY->[1] = " be changed";
print ARRAY->[1];
-Dereferencing constant references incorrectly (such as using an array
-subscript on a constant hash reference, or vice versa) will be trapped at
-compile time.
-
Constants belong to the package they are defined in. To refer to a
constant defined in another package, specify the full package name, as
in C<Some::Package::CONSTANT>. Constants may be exported by modules,
C<$obj> is an instance of C<Some::Package>. Subclasses may define
their own constants to override those in their base class.
+As of version 1.32 of this module, constants can be defined in packages
+other than the caller, by including the package name in the name of the
+constant:
+
+ use constant "OtherPackage::FWIBBLE" => 7865;
+ constant->import("Other::FWOBBLE",$value); # dynamically at run time
+
The use of all caps for constant names is merely a convention,
although it is recommended in order to make constants stand out
and to help avoid collisions with other barewords, keywords, and
use strict;
-use Test::More tests => 105;
+use Test::More tests => 109;
my $TB = Test::More->builder;
BEGIN { use_ok('constant'); }
$TB->current_test($curr_test+4);
eval q{ CCODE->{foo} };
-ok scalar($@ =~ /^Constant is not a HASH/);
+ok scalar($@ =~ /^Constant is not a HASH|Not a HASH reference/);
# Allow leading underscore
is $values[1], $values[0],
'modifying list const elements does not affect future retavls';
}
+
+use constant { "tahi" => 1, "rua::rua" => 2, "toru'toru" => 3 };
+use constant "wha::wha" => 4;
+is tahi, 1, 'unqualified constant declared with constants in other pkgs';
+is rua::rua, 2, 'constant declared with ::';
+is toru::toru, 3, "constant declared with '";
+is wha::wha, 4, 'constant declared by itself with ::';
use strict;
use warnings;
-our $VERSION = '1.95';
+our $VERSION = '1.96';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
=head1 VERSION
-This document describes threads version 1.92
+This document describes threads version 1.96
=head1 WARNING
ok(! defined($rc), 'Exited: threads->exit()');
-run_perl(prog => 'use threads 1.92;' .
+run_perl(prog => 'use threads 1.96;' .
'threads->exit(86);' .
'exit(99);',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
ok(! defined($rc), 'Exited: $thr->set_thread_exit_only');
-run_perl(prog => 'use threads 1.92 qw(exit thread_only);' .
+run_perl(prog => 'use threads 1.96 qw(exit thread_only);' .
'threads->create(sub { exit(99); })->join();' .
'exit(86);',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
is($?>>8, 86, "'use threads 'exit' => 'thread_only'");
}
-my $out = run_perl(prog => 'use threads 1.92;' .
+my $out = run_perl(prog => 'use threads 1.96;' .
'threads->create(sub {' .
' exit(99);' .
'});' .
like($out, qr/1 finished and unjoined/, "exit(status) in thread");
-$out = run_perl(prog => 'use threads 1.92 qw(exit thread_only);' .
+$out = run_perl(prog => 'use threads 1.96 qw(exit thread_only);' .
'threads->create(sub {' .
' threads->set_thread_exit_only(0);' .
' exit(99);' .
like($out, qr/1 finished and unjoined/, "set_thread_exit_only(0)");
-run_perl(prog => 'use threads 1.92;' .
+run_perl(prog => 'use threads 1.96;' .
'threads->create(sub {' .
' $SIG{__WARN__} = sub { exit(99); };' .
' die();' .
# bugid #24165
-run_perl(prog => 'use threads 1.92;' .
+run_perl(prog => 'use threads 1.96;' .
'sub a{threads->create(shift)} $t = a sub{};' .
'$t->tid; $t->join; $t->tid',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
SvTAINT(sv);
}
+
+/* used for: pp_keys(), pp_values() */
+
OP *
Perl_do_kv(pTHX)
{
return PL_op_seq;
}
+
+
+
+
const struct flag_to_name op_flags_names[] = {
{OPf_KIDS, ",KIDS"},
{OPf_PARENS, ",PARENS"},
{OPf_SPECIAL, ",SPECIAL"}
};
-const struct flag_to_name op_trans_names[] = {
- {OPpTRANS_FROM_UTF, ",FROM_UTF"},
- {OPpTRANS_TO_UTF, ",TO_UTF"},
- {OPpTRANS_IDENTICAL, ",IDENTICAL"},
- {OPpTRANS_SQUASH, ",SQUASH"},
- {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
- {OPpTRANS_GROWS, ",GROWS"},
- {OPpTRANS_DELETE, ",DELETE"}
-};
-
-const struct flag_to_name op_entersub_names[] = {
- {OPpENTERSUB_DB, ",DB"},
- {OPpENTERSUB_HASTARG, ",HASTARG"},
- {OPpENTERSUB_AMPER, ",AMPER"},
- {OPpENTERSUB_NOPAREN, ",NOPAREN"},
- {OPpENTERSUB_INARGS, ",INARGS"}
-};
-
-const struct flag_to_name op_const_names[] = {
- {OPpCONST_NOVER, ",NOVER"},
- {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
- {OPpCONST_STRICT, ",STRICT"},
- {OPpCONST_ENTERED, ",ENTERED"},
- {OPpCONST_BARE, ",BARE"}
-};
-
-const struct flag_to_name op_sort_names[] = {
- {OPpSORT_NUMERIC, ",NUMERIC"},
- {OPpSORT_INTEGER, ",INTEGER"},
- {OPpSORT_REVERSE, ",REVERSE"},
- {OPpSORT_INPLACE, ",INPLACE"},
- {OPpSORT_DESCEND, ",DESCEND"},
- {OPpSORT_QSORT, ",QSORT"},
- {OPpSORT_STABLE, ",STABLE"}
-};
-
-const struct flag_to_name op_open_names[] = {
- {OPpOPEN_IN_RAW, ",IN_RAW"},
- {OPpOPEN_IN_CRLF, ",IN_CRLF"},
- {OPpOPEN_OUT_RAW, ",OUT_RAW"},
- {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
-};
-
-const struct flag_to_name op_sassign_names[] = {
- {OPpASSIGN_BACKWARDS, ",BACKWARDS"},
- {OPpASSIGN_CV_TO_GV, ",CV2GV"}
-};
-
-const struct flag_to_name op_leave_names[] = {
- {OPpREFCOUNTED, ",REFCOUNTED"},
- {OPpLVALUE, ",LVALUE"}
-};
-
-#define OP_PRIVATE_ONCE(op, flag, name) \
- const struct flag_to_name CAT2(op, _names)[] = { \
- {(flag), (name)} \
- }
-
-OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
-OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
-OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
-OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
-OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
-OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
-OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
-OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
-OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
-OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
-OP_PRIVATE_ONCE(op_split, OPpSPLIT_IMPLIM, ",IMPLIM");
-OP_PRIVATE_ONCE(op_dbstate, OPpHUSH_VMSISH, ",HUSH_VMSISH");
-
-struct op_private_by_op {
- U16 op_type;
- U16 len;
- const struct flag_to_name *start;
-};
-
-const struct op_private_by_op op_private_names[] = {
- {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
- {OP_LEAVE, C_ARRAY_LENGTH(op_leave_names), op_leave_names },
- {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
- {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
- {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
- {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
- {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
- {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
- {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
- {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
- {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
- {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
- {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
- {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
- {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
- {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
- {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
- {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
- {OP_SPLIT, C_ARRAY_LENGTH(op_split_names), op_split_names },
- {OP_DBSTATE, C_ARRAY_LENGTH(op_dbstate_names), op_dbstate_names },
- {OP_NEXTSTATE, C_ARRAY_LENGTH(op_dbstate_names), op_dbstate_names },
- {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
-};
-
-static bool
-S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
- const struct op_private_by_op *start = op_private_names;
- const struct op_private_by_op *const end = C_ARRAY_END(op_private_names);
-
- /* This is a linear search, but no worse than the code that it replaced.
- It's debugging code - size is more important than speed. */
- do {
- if (optype == start->op_type) {
- S_append_flags(aTHX_ tmpsv, op_private, start->start,
- start->start + start->len);
- return TRUE;
- }
- } while (++start < end);
- return FALSE;
-}
-
-#define DUMP_OP_FLAGS(o,level,file) \
- if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
- SV * const tmpsv = newSVpvs(""); \
- switch (o->op_flags & OPf_WANT) { \
- case OPf_WANT_VOID: \
- sv_catpv(tmpsv, ",VOID"); \
- break; \
- case OPf_WANT_SCALAR: \
- sv_catpv(tmpsv, ",SCALAR"); \
- break; \
- case OPf_WANT_LIST: \
- sv_catpv(tmpsv, ",LIST"); \
- break; \
- default: \
- sv_catpv(tmpsv, ",UNKNOWN"); \
- break; \
- } \
- append_flags(tmpsv, o->op_flags, op_flags_names); \
- if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \
- 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 : ""); \
- }
-
-#define DUMP_OP_PRIVATE(o,level,file) \
- if (o->op_private) { \
- U32 optype = o->op_type; \
- U32 oppriv = o->op_private; \
- SV * const tmpsv = newSVpvs(""); \
- if (PL_opargs[optype] & OA_TARGLEX) { \
- if (oppriv & OPpTARGET_MY) \
- sv_catpv(tmpsv, ",TARGET_MY"); \
- } \
- else if (optype == OP_ENTERSUB || \
- optype == OP_RV2SV || \
- optype == OP_GVSV || \
- optype == OP_RV2AV || \
- optype == OP_RV2HV || \
- optype == OP_RV2GV || \
- optype == OP_AELEM || \
- optype == OP_HELEM ) \
- { \
- if (optype == OP_ENTERSUB) { \
- append_flags(tmpsv, oppriv, op_entersub_names); \
- } \
- else { \
- switch (oppriv & OPpDEREF) { \
- case OPpDEREF_SV: \
- sv_catpv(tmpsv, ",SV"); \
- break; \
- case OPpDEREF_AV: \
- sv_catpv(tmpsv, ",AV"); \
- break; \
- case OPpDEREF_HV: \
- sv_catpv(tmpsv, ",HV"); \
- break; \
- } \
- if (oppriv & OPpMAYBE_LVSUB) \
- sv_catpv(tmpsv, ",MAYBE_LVSUB"); \
- } \
- if (optype == OP_AELEM || optype == OP_HELEM) { \
- if (oppriv & OPpLVAL_DEFER) \
- sv_catpv(tmpsv, ",LVAL_DEFER"); \
- } \
- else if (optype == OP_RV2HV || optype == OP_PADHV) { \
- if (oppriv & OPpMAYBE_TRUEBOOL) \
- sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \
- if (oppriv & OPpTRUEBOOL) \
- sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \
- } \
- else { \
- if (oppriv & HINT_STRICT_REFS) \
- sv_catpv(tmpsv, ",STRICT_REFS"); \
- if (oppriv & OPpOUR_INTRO) \
- sv_catpv(tmpsv, ",OUR_INTRO"); \
- } \
- } \
- else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \
- } \
- else if (OP_IS_FILETEST(o->op_type)) { \
- if (oppriv & OPpFT_ACCESS) \
- sv_catpv(tmpsv, ",FT_ACCESS"); \
- if (oppriv & OPpFT_STACKED) \
- sv_catpv(tmpsv, ",FT_STACKED"); \
- if (oppriv & OPpFT_STACKING) \
- sv_catpv(tmpsv, ",FT_STACKING"); \
- if (oppriv & OPpFT_AFTER_t) \
- sv_catpv(tmpsv, ",AFTER_t"); \
- } \
- else if (o->op_type == OP_AASSIGN) { \
- if (oppriv & OPpASSIGN_COMMON) \
- sv_catpvs(tmpsv, ",COMMON"); \
- if (oppriv & OPpMAYBE_LVSUB) \
- sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \
- } \
- if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \
- sv_catpv(tmpsv, ",INTRO"); \
- if (o->op_type == OP_PADRANGE) \
- Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \
- (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \
- if ( (o->op_type == OP_RV2HV || o->op_type == OP_RV2AV || \
- o->op_type == OP_PADAV || o->op_type == OP_PADHV || \
- o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) \
- && oppriv & OPpSLICEWARNING ) \
- sv_catpvs(tmpsv, ",SLICEWARNING"); \
- if (SvCUR(tmpsv)) { \
- Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
- } else \
- Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
- (UV)oppriv); \
- }
-
void
Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
#endif
- DUMP_OP_FLAGS(o,level,file);
- DUMP_OP_PRIVATE(o,level,file);
+ if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
+ SV * const tmpsv = newSVpvs("");
+ switch (o->op_flags & OPf_WANT) {
+ case OPf_WANT_VOID:
+ sv_catpv(tmpsv, ",VOID");
+ break;
+ case OPf_WANT_SCALAR:
+ sv_catpv(tmpsv, ",SCALAR");
+ break;
+ case OPf_WANT_LIST:
+ sv_catpv(tmpsv, ",LIST");
+ break;
+ default:
+ sv_catpv(tmpsv, ",UNKNOWN");
+ break;
+ }
+ append_flags(tmpsv, o->op_flags, op_flags_names);
+ if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
+ 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 : "");
+ }
+
+ if (o->op_private) {
+ U16 oppriv = o->op_private;
+ I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
+ SV * tmpsv = NULL;
+
+ if (op_ix != -1) {
+ U16 stop = 0;
+ tmpsv = newSVpvs("");
+ for (; !stop; op_ix++) {
+ U16 entry = PL_op_private_bitdefs[op_ix];
+ U16 bit = (entry >> 2) & 7;
+ U16 ix = entry >> 5;
+
+ stop = (entry & 1);
+
+ if (entry & 2) {
+ /* bitfield */
+ I16 const *p = &PL_op_private_bitfields[ix];
+ U16 bitmin = (U16) *p++;
+ I16 label = *p++;
+ I16 enum_label;
+ U16 mask = 0;
+ U16 i;
+ U16 val;
+
+ for (i = bitmin; i<= bit; i++)
+ mask |= (1<<i);
+ bit = bitmin;
+ val = (oppriv & mask);
+
+ if ( label != -1
+ && PL_op_private_labels[label] == '-'
+ && PL_op_private_labels[label+1] == '\0'
+ )
+ /* display as raw number */
+ continue;
+
+ oppriv -= val;
+ val >>= bit;
+ enum_label = -1;
+ while (*p != -1) {
+ if (val == *p++) {
+ enum_label = *p;
+ break;
+ }
+ p++;
+ }
+ if (val == 0 && enum_label == -1)
+ /* don't display anonymous zero values */
+ continue;
+
+ sv_catpv(tmpsv, ",");
+ if (label != -1) {
+ sv_catpv(tmpsv, &PL_op_private_labels[label]);
+ sv_catpv(tmpsv, "=");
+ }
+ sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
+ }
+ else {
+ /* bit flag */
+ if ( oppriv & (1<<bit)
+ && !(PL_op_private_labels[ix] == '-'
+ && PL_op_private_labels[ix+1] == '\0'))
+ {
+ oppriv -= (1<<bit);
+ sv_catpv(tmpsv, ",");
+ sv_catpv(tmpsv, &PL_op_private_labels[ix]);
+ }
+ }
+ }
+ if (oppriv) {
+ sv_catpv(tmpsv, ",");
+ Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)oppriv);
+ }
+ }
+ if (tmpsv && SvCUR(tmpsv)) {
+ Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
+ } else
+ Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
+ (UV)oppriv);
+ }
switch (optype) {
case OP_AELEMFAST:
{CVf_CVGV_RC, "CVGV_RC,"},
{CVf_DYNFILE, "DYNFILE,"},
{CVf_AUTOLOAD, "AUTOLOAD,"},
- {CVf_HASEVAL, "HASEVAL"},
+ {CVf_HASEVAL, "HASEVAL,"},
{CVf_SLABBED, "SLABBED,"},
+ {CVf_NAMED, "NAMED,"},
+ {CVf_LEXICAL, "LEXICAL,"},
{CVf_ISXSUB, "ISXSUB,"}
};
{GVf_INTRO, "INTRO,"},
{GVf_MULTI, "MULTI,"},
{GVf_ASSUMECV, "ASSUMECV,"},
- {GVf_IN_PAD, "IN_PAD,"}
};
const struct flag_to_name gp_flags_imported_names[] = {
{PREGf_CANY_SEEN, "CANY_SEEN,"},
{PREGf_GPOS_SEEN, "GPOS_SEEN,"},
{PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
- {PREGf_ANCH_BOL, "ANCH_BOL,"},
{PREGf_ANCH_MBOL, "ANCH_MBOL,"},
{PREGf_ANCH_SBOL, "ANCH_SBOL,"},
{PREGf_ANCH_GPOS, "ANCH_GPOS,"},
&& type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
|| type == SVt_NV) {
STORE_NUMERIC_LOCAL_SET_STANDARD();
- /* %Vg doesn't work? --jhi */
-#ifdef USE_LONG_DOUBLE
- Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
-#else
- Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
-#endif
+ Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
}
Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
- if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
+ if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
dumpops, pvlim);
}
}
Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
+ Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
if (!GvGP(sv))
break;
Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
+ Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf
+ " (%s)\n",
+ (UV)GvGPFLAGS(sv),
+ GvALIASED_SV(sv) ? "ALIASED_SV" : "");
Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
- Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
do_gv_dump (level, file, " EGV", GvEGV(sv));
break;
case SVt_PVIO:
break;
case OP_GVSV:
case OP_GV:
- if (cGVOPo_gv) {
+ if (cGVOPo_gv && isGV(cGVOPo_gv)) {
SV * const sv = newSV(0);
gv_fullname3(sv, cGVOPo_gv, NULL);
PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
SvREFCNT_dec_NN(sv);
}
+ else if (cGVOPo_gv) {
+ SV * const sv = newSV(0);
+ assert(SvROK(cGVOPo_gv));
+ assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
+ PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
+ SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv)));
+ SvREFCNT_dec_NN(sv);
+ }
else
PerlIO_printf(Perl_debug_log, "(NULL)");
break;
:
: m Implemented as a macro:
:
-: suppress proto.h entry
+: suppress proto.h entry (actually, not suppressed, but commented out)
: suppress entry in the list of exported symbols
: suppress embed.h entry
:
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
+Ap |SV * |cv_name |NN CV *cv|NULLOK SV *sv
Apd |void |cv_undef |NN CV* cv
+p |void |cv_undef_flags |NN CV* cv|U32 flags
p |void |cv_forget_slab |NN CV *cv
Ap |void |cx_dump |NN PERL_CONTEXT* cx
Ap |SV* |filter_add |NULLOK filter_t funcp|NULLOK SV* datasv
: Used in scope.c
pMox |GP * |newGP |NN GV *const gv
pX |void |cvgv_set |NN CV* cv|NULLOK GV* gv
+poX |GV * |cvgv_from_hek |NN CV* cv
pX |void |cvstash_set |NN CV* cv|NULLOK HV* stash
Amd |void |gv_init |NN GV* gv|NULLOK HV* stash \
|NN const char* name|STRLEN len|int multi
XMpd |void |gv_try_downgrade|NN GV* gv
Apd |HV* |gv_stashpv |NN const char* name|I32 flags
Apd |HV* |gv_stashpvn |NN const char* name|U32 namelen|I32 flags
+#if defined(PERL_IN_GV_C)
+i |HV* |gv_stashpvn_internal|NN const char* name|U32 namelen|I32 flags
+i |HV* |gv_stashsvpvn_cached|NULLOK SV *namesv|NULLOK const char* name|U32 namelen|I32 flags
+#endif
Apd |HV* |gv_stashsv |NN SV* sv|I32 flags
Apd |void |hv_clear |NULLOK HV *hv
: used in SAVEHINTS() and op.c
|const STRLEN len
#endif
Apd |UV |grok_hex |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result
+Apdn |int |grok_infnan |NN const char** sp|NN const char *send
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
|NN SV *protosv
Apd |void |cv_get_call_checker|NN CV *cv|NN Perl_call_checker *ckfun_p|NN SV **ckobj_p
Apd |void |cv_set_call_checker|NN CV *cv|NN Perl_call_checker ckfun|NN SV *ckobj
+Apd |void |cv_set_call_checker_flags|NN CV *cv \
+ |NN Perl_call_checker ckfun \
+ |NN SV *ckobj|U32 flags
Apd |void |wrap_op_checker|Optype opcode|NN Perl_check_t new_checker|NN Perl_check_t *old_checker_p
Apa |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems
Ap |char* |scan_vstring |NN const char *s|NN const char *const e \
#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C)
ApM |SV* |_get_regclass_nonbitmap_data \
|NULLOK const regexp *prog \
- |NN const struct regnode *node|bool doinit \
+ |NN const struct regnode *node \
+ |bool doinit \
|NULLOK SV **listsvp \
- |NULLOK SV **lonly_utf8_locale
+ |NULLOK SV **lonly_utf8_locale \
+ |NULLOK SV *exclude_list
EXp |void|_load_PL_utf8_foldclosures|
#endif
#if defined(PERL_IN_REGCOMP_C) || defined (PERL_IN_DUMP_C)
sR |OP* |new_logop |I32 type|I32 flags|NN OP **firstp|NN OP **otherp
s |void |simplify_sort |NN OP *o
s |void |null_listop_in_list_context |NN OP* o
-s |SV* |gv_ename |NN GV *gv
sRn |bool |scalar_mod_type|NULLOK const OP *o|I32 type
s |OP * |my_kid |NULLOK OP *o|NULLOK OP *attrs|NN OP **imopsp
s |OP * |dup_attrlist |NN OP *o
s |void |bad_type_gv |I32 n|NN const char *t|NN GV *gv|U32 flags|NN const OP *kid
s |void |no_bareword_allowed|NN OP *o
sR |OP* |no_fh_allowed|NN OP *o
-sR |OP* |too_few_arguments_sv|NN OP *o|NN SV* namesv|U32 flags
sR |OP* |too_few_arguments_pv|NN OP *o|NN const char* name|U32 flags
s |OP* |too_many_arguments_pv|NN OP *o|NN const char* name|U32 flags
-sR |OP* |too_many_arguments_sv|NN OP *o|NN SV* namesv|U32 flags
s |bool |looks_like_bool|NN const OP* o
s |OP* |newGIVWHENOP |NULLOK OP* cond|NN OP *block \
|I32 enter_opcode|I32 leave_opcode \
|PADOFFSET entertarg
s |OP* |ref_array_or_hash|NULLOK OP* cond
-s |void |process_special_blocks |I32 floor \
+s |bool |process_special_blocks |I32 floor \
|NN const char *const fullname\
|NN GV *const gv|NN CV *const cv
s |void |clear_special_blocks |NN const char *const fullname\
#ifndef PERL_DISABLE_PMC
sR |PerlIO *|doopen_pm |NN SV *name
#endif
-s |SV ** |adjust_stack_on_leave|NN SV **newsp|NN SV **sp|NN SV **mark|I32 gimme \
+s |SV ** |leave_common |NN SV **newsp|NN SV **sp|NN SV **mark|I32 gimme \
|U32 flags|bool lvalue
iRn |bool |path_is_searchable|NN const char *name
sR |I32 |run_user_filter|int idx|NN SV *buf_sv|int maxlen
|NULLOK SV* const only_utf8_locale_list \
|NULLOK SV* const swash \
|const bool has_user_defined_property
+Es |AV* |add_multi_match|NULLOK AV* multi_char_matches \
+ |NN SV* multi_string \
+ |const STRLEN cp_count
Es |regnode*|regclass |NN RExC_state_t *pRExC_state \
|NN I32 *flagp|U32 depth|const bool stop_at_1 \
|bool allow_multi_fold \
Es |UV |reg_recode |const char value|NN SV **encp
Es |regnode*|regpiece |NN RExC_state_t *pRExC_state \
|NN I32 *flagp|U32 depth
-Es |bool |grok_bslash_N |NN RExC_state_t *pRExC_state \
+Es |STRLEN |grok_bslash_N |NN RExC_state_t *pRExC_state \
|NULLOK regnode** nodep|NULLOK UV *valuep \
- |NN I32 *flagp|U32 depth|bool in_char_class \
- |const bool strict
+ |NN I32 *flagp|U32 depth \
+ |NULLOK SV** substitute_parse
Es |void |reginsert |NN RExC_state_t *pRExC_state \
|U8 op|NN regnode *opnd|U32 depth
Es |void |regtail |NN RExC_state_t *pRExC_state \
|NULLOK const regnode *last \
|NULLOK const regnode *plast \
|NN SV* sv|I32 indent|U32 depth
-Es |void |put_byte |NN SV* sv|int c
-Es |bool |put_latin1_charclass_innards|NN SV* sv|NN char* bitmap
-Es |void |put_range |NN SV* sv|UV start|UV end
+EnPs |const char *|cntrl_to_mnemonic|const U8 c
+Es |void |put_code_point |NN SV* sv|UV c
+Es |bool |put_charclass_bitmap_innards|NN SV* sv \
+ |NN char* bitmap \
+ |NULLOK SV** bitmap_invlist
+Es |void |put_range |NN SV* sv|UV start|const UV end \
+ |const bool allow_literals
Es |void |dump_trie |NN const struct _reg_trie_data *trie\
|NULLOK HV* widecharmap|NN AV *revcharmap\
|U32 depth
s |void |force_ident |NN const char *s|int kind
s |void |force_ident_maybe_lex|char pit
s |void |incline |NN const char *s
-s |int |intuit_method |NN char *s|NULLOK GV *gv|NULLOK CV *cv
+s |int |intuit_method |NN char *s|NULLOK SV *ioname|NULLOK CV *cv
s |int |intuit_more |NN char *s
s |I32 |lop |I32 f|int x|NN char *s
rs |void |missingterm |NULLOK char *s
#endif
#if defined(PERL_IN_NUMERIC_C)
+#ifndef USE_QUADMATH
sn |NV|mulexp10 |NV value|I32 exponent
#endif
+#endif
#if defined(PERL_IN_UTF8_C)
sRM |UV |check_locale_boundary_crossing|NN const U8* const p|const UV result|NN U8* const ustrp|NN STRLEN *lenp
ApR |PerlIO *|PerlIO_stdin
ApR |PerlIO *|PerlIO_stdout
ApR |PerlIO *|PerlIO_stderr
-#endif /* PERLIO_LAYERS */
+#endif /* USE_PERLIO */
: Only used in dump.c
p |void |deb_stack_all
Apnodf |int |my_snprintf |NN char *buffer|const Size_t len|NN const char *format|...
Apnod |int |my_vsnprintf |NN char *buffer|const Size_t len|NN const char *format|va_list ap
+#ifdef USE_QUADMATH
+Apnd |const char* |quadmath_format_single|NN const char* format
+Apnd |bool|quadmath_format_needed|NN const char* format
+#endif
: Used in mg.c, sv.c
px |void |my_clearenv
Apnod |Size_t |my_strlcpy |NULLOK char *dst|NULLOK const char *src|Size_t size
#endif
+Apdn |bool |isinfnan |NV nv
+
#if !defined(HAS_SIGNBIT)
AMdnoP |int |Perl_signbit |NV f
#endif
#define cv_clone(a) Perl_cv_clone(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_name(a,b) Perl_cv_name(aTHX_ a,b)
#define cv_set_call_checker(a,b,c) Perl_cv_set_call_checker(aTHX_ a,b,c)
+#define cv_set_call_checker_flags(a,b,c,d) Perl_cv_set_call_checker_flags(aTHX_ a,b,c,d)
#define cv_undef(a) Perl_cv_undef(aTHX_ a)
#define cx_dump(a) Perl_cx_dump(aTHX_ a)
#define cxinc() Perl_cxinc(aTHX)
#define grok_atou Perl_grok_atou
#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_infnan Perl_grok_infnan
#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 is_utf8_xdigit(a) Perl_is_utf8_xdigit(aTHX_ a)
#define is_utf8_xidcont(a) Perl_is_utf8_xidcont(aTHX_ a)
#define is_utf8_xidfirst(a) Perl_is_utf8_xidfirst(aTHX_ a)
+#define isinfnan Perl_isinfnan
#define leave_scope(a) Perl_leave_scope(aTHX_ a)
#define lex_bufutf8() Perl_lex_bufutf8(aTHX)
#define lex_discard_to(a) Perl_lex_discard_to(aTHX_ a)
#define _new_invlist_C_array(a) Perl__new_invlist_C_array(aTHX_ a)
#endif
#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C)
-#define _get_regclass_nonbitmap_data(a,b,c,d,e) Perl__get_regclass_nonbitmap_data(aTHX_ a,b,c,d,e)
+#define _get_regclass_nonbitmap_data(a,b,c,d,e,f) Perl__get_regclass_nonbitmap_data(aTHX_ a,b,c,d,e,f)
#endif
#if defined(UNLINK_ALL_VERSIONS)
#define unlnk(a) Perl_unlnk(aTHX_ a)
#define PerlIO_unread(a,b,c) Perl_PerlIO_unread(aTHX_ a,b,c)
#define PerlIO_write(a,b,c) Perl_PerlIO_write(aTHX_ a,b,c)
#endif
+#if defined(USE_QUADMATH)
+#define quadmath_format_needed Perl_quadmath_format_needed
+#define quadmath_format_single Perl_quadmath_format_single
+#endif
#if defined(WIN32)
#define my_setlocale(a,b) Perl_my_setlocale(aTHX_ a,b)
#endif
#define yylex() Perl_yylex(aTHX)
# if defined(DEBUGGING)
# if defined(PERL_IN_REGCOMP_C)
+#define cntrl_to_mnemonic S_cntrl_to_mnemonic
#define dump_trie(a,b,c,d) S_dump_trie(aTHX_ a,b,c,d)
#define dump_trie_interim_list(a,b,c,d,e) S_dump_trie_interim_list(aTHX_ a,b,c,d,e)
#define dump_trie_interim_table(a,b,c,d,e) S_dump_trie_interim_table(aTHX_ a,b,c,d,e)
#define dumpuntil(a,b,c,d,e,f,g,h) S_dumpuntil(aTHX_ a,b,c,d,e,f,g,h)
-#define put_byte(a,b) S_put_byte(aTHX_ a,b)
-#define put_latin1_charclass_innards(a,b) S_put_latin1_charclass_innards(aTHX_ a,b)
-#define put_range(a,b,c) S_put_range(aTHX_ a,b,c)
+#define put_charclass_bitmap_innards(a,b,c) S_put_charclass_bitmap_innards(aTHX_ a,b,c)
+#define put_code_point(a,b) S_put_code_point(aTHX_ a,b)
+#define put_range(a,b,c,d) S_put_range(aTHX_ a,b,c,d)
#define regdump_extflags(a,b) S_regdump_extflags(aTHX_ a,b)
#define regdump_intflags(a,b) S_regdump_intflags(aTHX_ a,b)
#define regtail_study(a,b,c,d) S_regtail_study(aTHX_ a,b,c,d)
#define add_above_Latin1_folds(a,b,c) S_add_above_Latin1_folds(aTHX_ a,b,c)
#define add_cp_to_invlist(a,b) S_add_cp_to_invlist(aTHX_ a,b)
#define add_data S_add_data
+#define add_multi_match(a,b,c) S_add_multi_match(aTHX_ a,b,c)
#define alloc_maybe_populate_EXACT(a,b,c,d,e,f) S_alloc_maybe_populate_EXACT(aTHX_ a,b,c,d,e,f)
#define compute_EXACTish S_compute_EXACTish
#define construct_ahocorasick_from_trie(a,b,c) S_construct_ahocorasick_from_trie(aTHX_ a,b,c)
#define get_ANYOF_cp_list_for_ssc(a,b) S_get_ANYOF_cp_list_for_ssc(aTHX_ a,b)
#define get_invlist_iter_addr S_get_invlist_iter_addr
#define get_invlist_previous_index_addr S_get_invlist_previous_index_addr
-#define grok_bslash_N(a,b,c,d,e,f,g) S_grok_bslash_N(aTHX_ a,b,c,d,e,f,g)
+#define grok_bslash_N(a,b,c,d,e,f) S_grok_bslash_N(aTHX_ a,b,c,d,e,f)
#define handle_regex_sets(a,b,c,d,e) S_handle_regex_sets(aTHX_ a,b,c,d,e)
#define invlist_array S_invlist_array
#define invlist_clone(a) S_invlist_clone(aTHX_ a)
#define cv_clone_into(a,b) Perl_cv_clone_into(aTHX_ a,b)
#define cv_const_sv_or_av Perl_cv_const_sv_or_av
#define cv_forget_slab(a) Perl_cv_forget_slab(aTHX_ a)
+#define cv_undef_flags(a,b) Perl_cv_undef_flags(aTHX_ a,b)
#define cvgv_set(a,b) Perl_cvgv_set(aTHX_ a,b)
#define cvstash_set(a,b) Perl_cvstash_set(aTHX_ a,b)
#define deb_stack_all() Perl_deb_stack_all(aTHX)
#define utf16_textfilter(a,b,c) S_utf16_textfilter(aTHX_ a,b,c)
# endif
# endif
+# if !defined(USE_QUADMATH)
+# if defined(PERL_IN_NUMERIC_C)
+#define mulexp10 S_mulexp10
+# endif
+# endif
# if !defined(WIN32)
#define do_exec3(a,b,c) Perl_do_exec3(aTHX_ a,b,c)
# endif
#define gv_is_in_main(a,b,c) S_gv_is_in_main(aTHX_ a,b,c)
#define gv_magicalize(a,b,c,d,e,f) S_gv_magicalize(aTHX_ a,b,c,d,e,f)
#define gv_magicalize_isa(a) S_gv_magicalize_isa(aTHX_ a)
+#define gv_stashpvn_internal(a,b,c) S_gv_stashpvn_internal(aTHX_ a,b,c)
+#define gv_stashsvpvn_cached(a,b,c,d) S_gv_stashsvpvn_cached(aTHX_ a,b,c,d)
#define maybe_multimagic_gv(a,b,c) S_maybe_multimagic_gv(aTHX_ a,b,c)
#define parse_gv_stash_name(a,b,c,d,e,f,g,h) S_parse_gv_stash_name(aTHX_ a,b,c,d,e,f,g,h)
#define require_tie_mod(a,b,c,d,e) S_require_tie_mod(aTHX_ a,b,c,d,e)
#define mro_gather_and_rename(a,b,c,d,e) S_mro_gather_and_rename(aTHX_ a,b,c,d,e)
#define mro_get_linear_isa_dfs(a,b) S_mro_get_linear_isa_dfs(aTHX_ a,b)
# endif
-# if defined(PERL_IN_NUMERIC_C)
-#define mulexp10 S_mulexp10
-# endif
# if defined(PERL_IN_OP_C)
#define aassign_common_vars(a) S_aassign_common_vars(aTHX_ a)
#define apply_attrs(a,b,c) S_apply_attrs(aTHX_ a,b,c)
#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 inplace_aassign(a) S_inplace_aassign(aTHX_ a)
#define is_handle_constructor S_is_handle_constructor
#define is_list_assignment(a) S_is_list_assignment(aTHX_ a)
#define search_const(a) S_search_const(aTHX_ a)
#define simplify_sort(a) S_simplify_sort(aTHX_ a)
#define too_few_arguments_pv(a,b,c) S_too_few_arguments_pv(aTHX_ a,b,c)
-#define too_few_arguments_sv(a,b,c) S_too_few_arguments_sv(aTHX_ a,b,c)
#define too_many_arguments_pv(a,b,c) S_too_many_arguments_pv(aTHX_ a,b,c)
-#define too_many_arguments_sv(a,b,c) S_too_many_arguments_sv(aTHX_ a,b,c)
# endif
# if defined(PERL_IN_OP_C) || defined(PERL_IN_SV_C)
#define report_redefined_cv(a,b,c) Perl_report_redefined_cv(aTHX_ a,b,c)
#define refto(a) S_refto(aTHX_ a)
# endif
# if defined(PERL_IN_PP_CTL_C)
-#define adjust_stack_on_leave(a,b,c,d,e,f) S_adjust_stack_on_leave(aTHX_ a,b,c,d,e,f)
#define check_type_and_open(a) S_check_type_and_open(aTHX_ a)
#define destroy_matcher(a) S_destroy_matcher(aTHX_ a)
#define do_smartmatch(a,b,c) S_do_smartmatch(aTHX_ a,b,c)
#define dopoptoloop(a) S_dopoptoloop(aTHX_ a)
#define dopoptosub_at(a,b) S_dopoptosub_at(aTHX_ a,b)
#define dopoptowhen(a) S_dopoptowhen(aTHX_ a)
+#define leave_common(a,b,c,d,e,f) S_leave_common(aTHX_ a,b,c,d,e,f)
#define make_matcher(a) S_make_matcher(aTHX_ a)
#define matcher_matches_sv(a,b) S_matcher_matches_sv(aTHX_ a,b)
#define num_overflow S_num_overflow
#define PL_Dir (vTHX->IDir)
#define PL_Env (vTHX->IEnv)
#define PL_HasMultiCharFold (vTHX->IHasMultiCharFold)
+#define PL_InBitmap (vTHX->IInBitmap)
#define PL_LIO (vTHX->ILIO)
#define PL_Latin1 (vTHX->ILatin1)
#define PL_Mem (vTHX->IMem)
#define PL_comppad_name (vTHX->Icomppad_name)
#define PL_comppad_name_fill (vTHX->Icomppad_name_fill)
#define PL_comppad_name_floor (vTHX->Icomppad_name_floor)
+#define PL_constpadix (vTHX->Iconstpadix)
#define PL_cop_seqmax (vTHX->Icop_seqmax)
#define PL_cryptseen (vTHX->Icryptseen)
#define PL_curcop (vTHX->Icurcop)
#define PL_savestack (vTHX->Isavestack)
#define PL_savestack_ix (vTHX->Isavestack_ix)
#define PL_savestack_max (vTHX->Isavestack_max)
+#define PL_sawalias (vTHX->Isawalias)
#ifndef PL_sawampersand
#define PL_sawampersand (vTHX->Isawampersand)
#endif
# walkoptree comes from B.xs
BEGIN {
- $B::VERSION = '1.50';
+ $B::VERSION = '1.51';
@B::EXPORT_OK = ();
# Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.
parents comppadlist sv_undef compile_stats timing_info
begin_av init_av check_av end_av regex_padav dowarn
defstash curstash warnhook diehook inc_gv @optype
- @specialsv_name unitcheck_av));
+ @specialsv_name unitcheck_av safename));
@B::SV::ISA = 'B::OBJECT';
@B::NULL::ISA = 'B::SV';
}
sub B::GV::SAFENAME {
- my $name = (shift())->NAME;
+ safename(shift()->NAME);
+}
+
+sub safename {
+ my $name = shift;
# The regex below corresponds to the isCONTROLVAR macro
# from toke.c
Returns a double-quote-surrounded escaped version of STR which can
be used as a string in Perl source code.
+=item safename(STR)
+
+This function returns the string with the first character modified if it
+is a control character. It converts it to ^X format first, so that "\cG"
+becomes "^G". This is used internally by L<B::GV::SAFENAME|/SAFENAME>, but
+you can call it directly.
+
=item class(OBJ)
Returns the class of an object without the part of the classname
=item threadsv_names
-In a perl compiled for threads, this returns a list of the special
-per-thread threadsv variables.
+This used to provide support for the old 5.005 threading module. It now
+does nothing.
=back
#if PERL_VERSION >= 17
{ STR_WITH_LEN("code_list"),OPp, STRUCT_OFFSET(struct pmop, op_code_list),},/*13*/
#else
- { STR_WITH_LEN("code_list"),op_offset_special, 0,
+ { STR_WITH_LEN("code_list"),op_offset_special, 0, }, /*13*/
#endif
{ STR_WITH_LEN("sv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*14*/
{ STR_WITH_LEN("gv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*15*/
if (op_methods[ix].type == op_offset_special)
switch (ix) {
- case 1: /* op_sibling */
+ case 1: /* B::OP::op_sibling */
ret = make_op_object(aTHX_ OP_SIBLING(o));
break;
- case 8: /* pmreplstart */
+ case 8: /* B::PMOP::pmreplstart */
ret = make_op_object(aTHX_
cPMOPo->op_type == OP_SUBST
? cPMOPo->op_pmstashstartu.op_pmreplstart
);
break;
#ifdef USE_ITHREADS
- case 21: /* filegv */
+ case 21: /* B::COP::filegv */
ret = make_sv_object(aTHX_ (SV *)CopFILEGV((COP*)o));
break;
#endif
#ifndef USE_ITHREADS
- case 22: /* file */
+ case 22: /* B::COP::file */
ret = sv_2mortal(newSVpv(CopFILE((COP*)o), 0));
break;
#endif
#ifdef USE_ITHREADS
- case 23: /* stash */
+ case 23: /* B::COP::stash */
ret = make_sv_object(aTHX_ (SV *)CopSTASH((COP*)o));
break;
#endif
#if PERL_VERSION >= 17 || !defined USE_ITHREADS
- case 24: /* stashpv */
+ case 24: /* B::COP::stashpv */
# if PERL_VERSION >= 17
ret = sv_2mortal(CopSTASH((COP*)o)
&& SvTYPE(CopSTASH((COP*)o)) == SVt_PVHV
# endif
break;
#endif
- case 26: /* size */
+ case 26: /* B::OP::size */
ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)])));
break;
- case 27: /* name */
- case 28: /* desc */
+ case 27: /* B::OP::name */
+ case 28: /* B::OP::desc */
ret = sv_2mortal(newSVpv(
(char *)(ix == 28 ? OP_DESC(o) : OP_NAME(o)), 0));
break;
- case 29: /* ppaddr */
+ case 29: /* B::OP::ppaddr */
{
int i;
ret = sv_2mortal(Perl_newSVpvf(aTHX_ "PL_ppaddr[OP_%s]",
SvPVX(ret)[i] = toUPPER(SvPVX(ret)[i]);
}
break;
- case 30: /* type */
- case 31: /* opt */
- case 32: /* spare */
+ case 30: /* B::OP::type */
+ case 31: /* B::OP::opt */
+ case 32: /* B::OP::spare */
#if PERL_VERSION >= 17
- case 47: /* slabbed */
- case 48: /* savefree */
- case 49: /* static */
+ case 47: /* B::OP::slabbed */
+ case 48: /* B::OP::savefree */
+ case 49: /* B::OP::static */
#if PERL_VERSION >= 19
- case 50: /* folded */
- case 51: /* lastsib */
+ case 50: /* B::OP::folded */
+ case 51: /* B::OP::lastsib */
#endif
#endif
/* These are all bitfields, so we can't take their addresses */
: ix == 51 ? o->op_lastsib
: o->op_spare)));
break;
- case 33: /* children */
+ case 33: /* B::LISTOP::children */
{
OP *kid;
UV i = 0;
ret = sv_2mortal(newSVuv(i));
}
break;
- case 34: /* pmreplroot */
+ case 34: /* B::PMOP::pmreplroot */
if (cPMOPo->op_type == OP_PUSHRE) {
#ifdef USE_ITHREADS
ret = sv_newmortal();
}
break;
#ifdef USE_ITHREADS
- case 35: /* pmstashpv */
+ case 35: /* B::PMOP::pmstashpv */
ret = sv_2mortal(newSVpv(PmopSTASHPV(cPMOPo),0));
break;
#else
- case 36: /* pmstash */
+ case 36: /* B::PMOP::pmstash */
ret = make_sv_object(aTHX_ (SV *) PmopSTASH(cPMOPo));
break;
#endif
- case 37: /* precomp */
- case 38: /* reflags */
+ case 37: /* B::PMOP::precomp */
+ case 38: /* B::PMOP::reflags */
{
REGEXP *rx = PM_GETRE(cPMOPo);
ret = sv_newmortal();
}
}
break;
- case 39: /* sv */
- case 40: /* gv */
- /* It happens that the output typemaps for B::SV and B::GV
- * are identical. The "smarts" are in make_sv_object(),
- * which determines which class to use based on SvTYPE(),
- * rather than anything baked in at compile time. */
- if (cPADOPo->op_padix) {
- ret = PAD_SVl(cPADOPo->op_padix);
- if (ix == 40 && SvTYPE(ret) != SVt_PVGV)
- ret = NULL;
- } else {
- ret = NULL;
- }
- ret = make_sv_object(aTHX_ ret);
+ case 39: /* B::PADOP::sv */
+ case 40: /* B::PADOP::gv */
+ /* PADOPs should only be created on threaded builds.
+ * They don't have an sv or gv field, just an op_padix
+ * field. Leave it to the caller to retrieve padix
+ * and look up th value in the pad. Don't do it here,
+ * becuase PL_curpad is the pad of the caller, not the
+ * pad of the sub the op is part of */
+ ret = make_sv_object(aTHX_ NULL);
break;
- case 41: /* pv */
+ case 41: /* B::PVOP::pv */
/* OP_TRANS uses op_pv to point to a table of 256 or >=258
* shorts whereas other PVOPs point to a null terminated
* string. */
else
ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), SVs_TEMP);
break;
- case 42: /* label */
+ case 42: /* B::COP::label */
ret = sv_2mortal(newSVpv(CopLABEL(cCOPo),0));
break;
- case 43: /* arybase */
+ case 43: /* B::COP::arybase */
ret = sv_2mortal(newSVuv(0));
break;
- case 44: /* warnings */
+ case 44: /* B::COP::warnings */
ret = make_warnings_object(aTHX_ cCOPo);
break;
- case 45: /* io */
+ case 45: /* B::COP::io */
ret = make_cop_io_object(aTHX_ cCOPo);
break;
- case 46: /* hints_hash */
+ case 46: /* B::COP::hints_hash */
ret = sv_newmortal();
sv_setiv(newSVrv(ret, "B::RHE"),
PTR2IV(CopHINTHASH_get(cCOPo)));
break;
- case 52: /* parent */
+ case 52: /* B::OP::parent */
ret = make_op_object(aTHX_ op_parent(o));
break;
default:
use Exporter (); # use #5
-our $VERSION = "0.992";
+our $VERSION = "0.993";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw( set_style set_style_standard add_callback
concise_subref concise_cv concise_main
return $text; # suppress empty lines
}
-our %priv; # used to display each opcode's BASEOP.op_private values
-
-$priv{$_}{128} = "LVINTRO"
- for qw(pos substr vec threadsv gvsv rv2sv rv2hv rv2gv rv2av rv2arylen
- aelem helem aslice hslice padsv padav padhv enteriter entersub
- padrange pushmark);
-$priv{$_}{64} = "REFC" for qw(leave leavesub leavesublv leavewrite);
-$priv{$_}{128} = "LV" for qw(leave leaveloop);
-@{$priv{aassign}}{32,64} = qw(STATE COMMON);
-@{$priv{sassign}}{32,64,128} = qw(STATE BKWARD CV2GV);
-$priv{$_}{64} = "RTIME" for qw(match subst substcont qr);
-@{$priv{$_}}{1,2,4,8,16,64} = qw(<UTF >UTF IDENT SQUASH DEL COMPL GROWS)
- for qw(trans transr);
-$priv{repeat}{64} = "DOLIST";
-$priv{leaveloop}{64} = "CONT";
-@{$priv{$_}}{32,64,96} = qw(DREFAV DREFHV DREFSV)
- for qw(rv2gv rv2sv padsv aelem helem);
-$priv{$_}{16} = "STATE" for qw(padav padhv padsv);
-@{$priv{rv2gv}}{4,16} = qw(NOINIT FAKE);
-@{$priv{entersub}}{1,4,16,32,64} = qw(INARGS TARG DBG DEREF);
-@{$priv{rv2cv}}{1,8,128} = qw(CONST AMPER NO());
-$priv{gv}{32} = "EARLYCV";
-$priv{$_}{16} = "LVDEFER" for qw(aelem helem);
-$priv{$_}{16} = "OURINTR" for qw(gvsv rv2sv rv2av rv2hv r2gv enteriter);
-$priv{$_}{8} = "LVSUB"
- for qw(rv2av rv2gv rv2hv padav padhv aelem helem aslice hslice
- av2arylen keys rkeys substr pos vec);
-$priv{$_}{4} = "SLICEWARN"
- for qw(rv2hv rv2av padav padhv hslice aslice);
-@{$priv{$_}}{32,64} = qw(BOOL BOOL?) for qw(rv2hv padhv);
-$priv{substr}{16} = "REPL1ST";
-$priv{$_}{16} = "TARGMY"
- for map(($_,"s$_"), qw(chop chomp)),
- map(($_,"i_$_"), qw(postinc postdec multiply divide modulo add
- subtract negate)),
- qw(pow concat stringify left_shift right_shift bit_and bit_xor
- bit_or complement atan2 sin cos rand exp log sqrt int hex oct
- abs length index rindex sprintf ord chr crypt quotemeta join
- push unshift flock chdir chown chroot unlink chmod utime rename
- link symlink mkdir rmdir wait waitpid system exec kill getppid
- getpgrp setpgrp getpriority setpriority time sleep);
-$priv{$_}{4} = "REVERSED" for qw(enteriter iter);
-@{$priv{const}}{2,4,8,16,64} = qw(NOVER SHORT STRICT ENTERED BARE);
-$priv{$_}{64} = "LINENUM" for qw(flip flop);
-$priv{list}{64} = "GUESSED";
-$priv{delete}{64} = "SLICE";
-$priv{exists}{64} = "SUB";
-@{$priv{sort}}{1,2,4,8,16,32,64} = qw(NUM INT REV INPLACE DESC QSORT STABLE);
-$priv{reverse}{8} = "INPLACE";
-$priv{threadsv}{64} = "SVREFd";
-@{$priv{$_}}{16,32,64,128} = qw(INBIN INCR OUTBIN OUTCR)
- for qw(open backtick);
-$priv{$_}{32} = "HUSH" for qw(nextstate dbstate);
-$priv{$_}{2} = "FTACCESS"
- for qw(ftrread ftrwrite ftrexec fteread ftewrite fteexec);
-@{$priv{entereval}}{2,4,8,16} = qw(HAS_HH UNI BYTES COPHH);
-@{$priv{$_}}{4,8,16} = qw(FTSTACKED FTSTACKING FTAFTERt)
- for qw(ftrread ftrwrite ftrexec fteread ftewrite fteexec ftis fteowned
- ftrowned ftzero ftsize ftmtime ftatime ftctime ftsock ftchr
- ftblk ftfile ftdir ftpipe ftlink ftsuid ftsgid ftsvtx fttty
- fttext ftbinary);
-$priv{$_}{2} = "GREPLEX"
- for qw(mapwhile mapstart grepwhile grepstart);
-$priv{$_}{128} = "+1" for qw(caller wantarray runcv);
-@{$priv{coreargs}}{1,2,64,128} = qw(DREF1 DREF2 $MOD MARK);
-$priv{$_}{128} = "UTF" for qw(last redo next goto dump);
-$priv{split}{128} = "IMPLIM";
+
+
+# use require rather than use here to avoid disturbing tests that dump
+# BEGIN blocks
+require B::Op_private;
+
+
our %hints; # used to display each COP's op_hints values
return join(",", @s);
}
+# return a string like 'LVINTRO,1' for the op $name with op_private
+# value $x
+
sub private_flags {
my($name, $x) = @_;
- _flags($priv{$name}, $x);
+ my $entry = $B::Op_private::bits{$name};
+ return $x ? "$x" : '' unless $entry;
+
+ my @flags;
+ my $bit;
+ for ($bit = 7; $bit >= 0; $bit--) {
+ next unless exists $entry->{$bit};
+ my $e = $entry->{$bit};
+ if (ref($e) eq 'HASH') {
+ # bit field
+
+ my ($bitmin, $bitmax, $bitmask, $enum, $label) =
+ @{$e}{qw(bitmin bitmax bitmask enum label)};
+ $bit = $bitmin;
+ next if defined $label && $label eq '-'; # display as raw number
+
+ my $val = $x & $bitmask;
+ $x &= ~$bitmask;
+ $val >>= $bitmin;
+
+ if (defined $enum) {
+ # try to convert numeric $val into symbolic
+ my @enum = @$enum;
+ while (@enum) {
+ my $ix = shift @enum;
+ my $name = shift @enum;
+ my $label = shift @enum;
+ if ($val == $ix) {
+ $val = $label;
+ last;
+ }
+ }
+ }
+ next if $val eq '0'; # don't display anonymous zero values
+ push @flags, defined $label ? "$label=$val" : $val;
+
+ }
+ else {
+ # flag bit
+ my $label = $B::Op_private::labels{$e};
+ next if defined $label && $label eq '-'; # display as raw number
+ if ($x & (1<<$bit)) {
+ $x -= (1<<$bit);
+ push @flags, $label;
+ }
+ }
+ }
+
+ push @flags, $x if $x; # display unknown bits numerically
+ return join ",", @flags;
}
sub hints_flags {
$h{class} = class($op);
$h{extarg} = $h{targ} = $op->targ;
$h{extarg} = "" unless $h{extarg};
+ $h{privval} = $op->private;
+ $h{private} = private_flags($h{name}, $op->private);
+ if ($op->folded) {
+ $h{private} &&= "$h{private},";
+ $h{private} .= "FOLD";
+ }
+
if ($h{name} eq "null" and $h{targ}) {
# targ holds the old type
$h{exname} = "ex-" . substr(ppname($h{targ}), 3);
$h{extarg} = "";
- } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) {
- # targ potentially holds a reference count
- if ($op->private & 64) {
- my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
- $h{targarglife} = $h{targarg} = "$h{targ} $refs";
- }
+ } elsif ($h{private} =~ /\bREFC\b/) {
+ # targ holds a reference count
+ my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
+ $h{targarglife} = $h{targarg} = "$h{targ} $refs";
} elsif ($h{targ}) {
- my $count = $h{name} eq 'padrange' ? ($op->private & 127) : 1;
+ my $count = $h{name} eq 'padrange'
+ ? ($op->private & $B::Op_private::defines{'OPpPADRANGE_COUNTMASK'})
+ : 1;
my (@targarg, @targarglife);
for my $i (0..$count-1) {
my ($targarg, $targarglife);
$h{classsym} = $opclass{$h{class}};
$h{flagval} = $op->flags;
$h{flags} = op_flags($op->flags);
- $h{privval} = $op->private;
- $h{private} = private_flags($h{name}, $op->private);
- if ($op->folded) {
- $h{private} &&= "$h{private},";
- $h{private} .= "FOLD";
- }
if ($op->can("hints")) {
$h{hintsval} = $op->hints;
$h{hints} = hints_flags($h{hintsval});
They're opcode specific, and occur less often than the public ones, so
they're represented by short mnemonics instead of single-chars; see
-F<op.h> for gory details, or try this quick 2-liner:
-
- $> perl -MB::Concise -de 1
- DB<1> |x \%B::Concise::priv
+B::Op_private and F<regen/op_private> for more details.
=head1 FORMATTING SPECIFICATIONS
['cv.h', 'CVf'],
['gv.h', 'GVf'],
['op.h'],
+ ['opcode.h', 'OPp'],
['op_reg_common.h','(?:(?:RXf_)?PMf_)'],
['regexp.h','RXf_'],
['sv.h', 'SV(?:[fps]|pad)_'],
can_ok $f, 'LINES';
}
+is B::safename("\cLAST_FH"), "^LAST_FH", 'basic safename test';
+
my $sub1 = sub {die};
{ no warnings 'once'; no strict; *Peel:: = *{"Pe\0e\x{142}::"} }
my $sub2 = eval 'package Peel; sub {die}';
my $cv = B::svref_2object(\&bar);
ok($cv, "make a B::CV from a lexical sub reference");
isa_ok($cv, "B::CV");
- my $gv = $cv->GV;
- isa_ok($gv, "B::SPECIAL", "GV on a lexical sub");
my $hek = $cv->NAME_HEK;
is($hek, "bar", "check the NAME_HEK");
+ my $gv = $cv->GV;
+ isa_ok($gv, "B::GV", "GV on a lexical sub");
}
1;
EOS
}
+# make sure ->sv, -gv methods do the right thing on threaded builds
+{
+
+ # for some reason B::walkoptree only likes a sub name, not a code ref
+ my ($gv, $sv);
+ sub gvsv_const {
+ # make the early pad slots something unlike a threaded const or
+ # gvsv
+ my ($dummy1, $dummy2, $dummy3, $dummy4) = qw(foo1 foo2 foo3 foo4);
+ my $self = shift;
+ if ($self->name eq 'gvsv') {
+ $gv = $self->gv;
+ }
+ elsif ($self->name eq 'const') {
+ $sv = $self->sv;
+ }
+ };
+
+ B::walkoptree(B::svref_2object(sub {our $x = 1})->ROOT, "::gvsv_const");
+ ok(defined $gv, "gvsv->gv seen");
+ ok(defined $sv, "const->sv seen");
+ if ($Config::Config{useithreads}) {
+ # should get NULLs
+ is(ref($gv), "B::SPECIAL", "gvsv->gv is special");
+ is(ref($sv), "B::SPECIAL", "const->sv is special");
+ is($$gv, 0, "gvsv->gv special is 0 (NULL)");
+ is($$sv, 0, "const->sv special is 0 (NULL)");
+ }
+ else {
+ is(ref($gv), "B::GV", "gvsv->gv is GV");
+ is(ref($sv), "B::IV", "const->sv is IV");
+ pass();
+ pass();
+ }
+
+}
+
+
done_testing();
perl => [qw(
walksymtable walkoptree_slow walkoptree_exec
timing_info savesym peekop parents objsym debug
- compile_stats clearsym class
+ compile_stats clearsym class safename
)],
XS => [qw(
warnhook walkoptree_debug walkoptree threadsv_names
PMf_MULTILINE PMf_ONCE PMf_SINGLELINE
POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK
SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE
- OPpCONST_ARYBASE RXf_SKIPWHITE/,
+ OPpCONST_ARYBASE RXf_SKIPWHITE SVpad_TYPED/,
$] >= 5.015 ? qw(
OP_GLOB PMf_SKIPWHITE RXf_PMf_CHARSET RXf_PMf_KEEPCOPY
OPpEVAL_BYTES OPpSUBSTR_REPL_FIRST) : (),
qw /WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
WSTOPSIG WTERMSIG/,
'int_macro_int', # Removed in POSIX 1.16
+
+ 'strtold', # platform varying (C99)
+
+ qw/fegetround fesetround/,
+
+ # C99 math
+ qw/acosh asinh atanh cbrt copysign cosh erf
+ erfc exp2 expm1 fdim fma fmax fmin fpclassify
+ hypot ilogb isfinite isgreater isgreaterequal
+ isinf isless islessequal islessgreater isnan
+ isnormal isunordered j0 j1 jn lgamma log1p
+ log2 logb lrint lround nan nearbyint nextafter
+ nexttoward remainder remquo rint round scalbn
+ signbit sinh tanh tgamma trunc y0 y1 yn/,
+
],
perl => [qw/ import croak AUTOLOAD /,
$] >= 5.015
# c <1> rv2av[t6] sKRM/1
# d <#> gv[*_] s
# e <1> rv2gv sKRM/1
-# f <{> enteriter(next->q last->t redo->g) lKS/8
+# f <{> enteriter(next->q last->t redo->g) lKS/DEF
# r <0> iter s
# s <|> and(other->g) K/1
# g <;> nextstate(main 475 (eval 10):1) v:{
# c <1> rv2av[t3] sKRM/1
# d <$> gv(*_) s
# e <1> rv2gv sKRM/1
-# f <{> enteriter(next->q last->t redo->g) lKS/8
+# f <{> enteriter(next->q last->t redo->g) lKS/DEF
# r <0> iter s
# s <|> and(other->g) K/1
# g <;> nextstate(main 559 (eval 15):1) v:{
( name => 'cmdline self-strict compile err using prog',
prog => 'use strict; sort @a',
bcopts => [qw/ -basic -concise -exec /],
- errs => 'Global symbol "@a" requires explicit package name at -e line 1.',
+ errs => 'Global symbol "@a" requires explicit package name (did you forget to declare "my @a"?) at -e line 1.',
expect => 'nextstate',
expect_nt => 'nextstate',
noanchors => 1, # allow simple expectations to work
( name => 'cmdline self-strict compile err using code',
code => 'use strict; sort @a',
bcopts => [qw/ -basic -concise -exec /],
- errs => qr/Global symbol "\@a" requires explicit package name at .*? line 1\./,
+ errs => qr/Global symbol "\@a" requires explicit package (?x:
+ )name \(did you forget to declare "my \@a"\?\) at (?x:
+ ).*? line 1\./,
note => 'this test relys on a kludge which copies $@ to rendering when empty',
expect => 'Global symbol',
expect_nt => 'Global symbol',
# 3 <$> const[IV 1] s
# 4 <$> const[IV 10] s
# 5 <#> gv[*_] s
-# 6 <{> enteriter(next->d last->g redo->7) lKS/8
+# 6 <{> enteriter(next->d last->g redo->7) lKS/DEF
# e <0> iter s
# f <|> and(other->7) K/1
# 7 <;> nextstate(main 442 optree.t:158) v:>,<,%
# 3 <$> const(IV 1) s
# 4 <$> const(IV 10) s
# 5 <$> gv(*_) s
-# 6 <{> enteriter(next->d last->g redo->7) lKS/8
+# 6 <{> enteriter(next->d last->g redo->7) lKS/DEF
# e <0> iter s
# f <|> and(other->7) K/1
# 7 <;> nextstate(main 443 optree_samples.t:182) v:>,<,%
# - <@> lineseq KP ->g
# 1 <;> nextstate(main 445 optree.t:167) v:>,<,% ->2
# f <2> leaveloop K/2 ->g
-# 6 <{> enteriter(next->c last->f redo->7) lKS/8 ->d
+# 6 <{> enteriter(next->c last->f redo->7) lKS/DEF ->d
# - <0> ex-pushmark s ->2
# - <1> ex-list lK ->5
# 2 <0> pushmark s ->3
# - <@> lineseq KP ->g
# 1 <;> nextstate(main 446 optree_samples.t:192) v:>,<,% ->2
# f <2> leaveloop K/2 ->g
-# 6 <{> enteriter(next->c last->f redo->7) lKS/8 ->d
+# 6 <{> enteriter(next->c last->f redo->7) lKS/DEF ->d
# - <0> ex-pushmark s ->2
# - <1> ex-list lK ->5
# 2 <0> pushmark s ->3
# 4 <$> const[IV 1] s
# 5 <$> const[IV 10] s
# 6 <#> gv[*_] s
-# 7 <{> enteriter(next->e last->h redo->8) lKS/8
+# 7 <{> enteriter(next->e last->h redo->8) lKS/DEF
# f <0> iter s
# g <|> and(other->8) vK/1
# 8 <;> nextstate(main 1 -e:1) v:>,<,%
# 4 <$> const(IV 1) s
# 5 <$> const(IV 10) s
# 6 <$> gv(*_) s
-# 7 <{> enteriter(next->e last->h redo->8) lKS/8
+# 7 <{> enteriter(next->e last->h redo->8) lKS/DEF
# f <0> iter s
# g <|> and(other->8) vK/1
# 8 <;> nextstate(main 1 -e:1) v:>,<,%
# 3 <$> const[IV 1] s
# 4 <$> const[IV 10] s
# 5 <#> gv[*_] s
-# 6 <{> enteriter(next->c last->f redo->7) lKS/8
+# 6 <{> enteriter(next->c last->f redo->7) lKS/DEF
# d <0> iter s
# e <|> and(other->7) K/1
# 7 <0> pushmark s
# 3 <$> const(IV 1) s
# 4 <$> const(IV 10) s
# 5 <$> gv(*_) s
-# 6 <{> enteriter(next->c last->f redo->7) lKS/8
+# 6 <{> enteriter(next->c last->f redo->7) lKS/DEF
# d <0> iter s
# e <|> and(other->7) K/1
# 7 <0> pushmark s
# a <1> rv2av[t6] sKRM/1
# b <#> gv[*_] s
# c <1> rv2gv sKRM/1
-# d <{> enteriter(next->o last->r redo->e) lKS/8
+# d <{> enteriter(next->o last->r redo->e) lKS/DEF
# p <0> iter s
# q <|> and(other->e) K/1
# e <;> nextstate(main 505 (eval 24):1) v:{
# a <1> rv2av[t3] sKRM/1
# b <$> gv(*_) s
# c <1> rv2gv sKRM/1
-# d <{> enteriter(next->o last->r redo->e) lKS/8
+# d <{> enteriter(next->o last->r redo->e) lKS/DEF
# p <0> iter s
# q <|> and(other->e) K/1
# e <;> nextstate(main 505 (eval 24):1) v:{
# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ ->5
# - <@> lineseq K ->-
# - <0> null ->5
-# 9 <1> entersub[t1] KS*/TARG,2 ->a
+# 9 <1> entersub[t1] KS*/TARG,STRICT ->a
# 5 <0> pushmark s ->6
# 6 <$> const[PV "strict"] sM ->7
# 7 <$> const[PV "refs"] sM ->8
# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ ->f
# - <@> lineseq K ->-
# - <0> null ->f
-# j <1> entersub[t1] KS*/TARG,2 ->k
+# j <1> entersub[t1] KS*/TARG,STRICT ->k
# f <0> pushmark s ->g
# g <$> const[PV "strict"] sM ->h
# h <$> const[PV "refs"] sM ->i
# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ ->p
# - <@> lineseq K ->-
# - <0> null ->p
-# t <1> entersub[t1] KS*/TARG,2 ->u
+# t <1> entersub[t1] KS*/TARG,STRICT ->u
# p <0> pushmark s ->q
# q <$> const[PV "warnings"] sM ->r
# r <$> const[PV "qw"] sM ->s
# 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ ->5
# - <@> lineseq K ->-
# - <0> null ->5
-# 9 <1> entersub[t1] KS*/TARG,2 ->a
+# 9 <1> entersub[t1] KS*/TARG,STRICT ->a
# 5 <0> pushmark s ->6
# 6 <$> const(PV "strict") sM ->7
# 7 <$> const(PV "refs") sM ->8
# e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ ->f
# - <@> lineseq K ->-
# - <0> null ->f
-# j <1> entersub[t1] KS*/TARG,2 ->k
+# j <1> entersub[t1] KS*/TARG,STRICT ->k
# f <0> pushmark s ->g
# g <$> const(PV "strict") sM ->h
# h <$> const(PV "refs") sM ->i
# o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ ->p
# - <@> lineseq K ->-
# - <0> null ->p
-# t <1> entersub[t1] KS*/TARG,2 ->u
+# t <1> entersub[t1] KS*/TARG,STRICT ->u
# p <0> pushmark s ->q
# q <$> const(PV "warnings") sM ->r
# r <$> const(PV "qw") sM ->s
# 6 <$> const[PV "strict"] sM
# 7 <$> const[PV "refs"] sM
# 8 <$> method_named[PV "unimport"]
-# 9 <1> entersub[t1] KS*/TARG,2
+# 9 <1> entersub[t1] KS*/TARG,STRICT
# a <1> leavesub[1 ref] K/REFC,1
# BEGIN 2:
# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$
# g <$> const[PV "strict"] sM
# h <$> const[PV "refs"] sM
# i <$> method_named[PV "unimport"]
-# j <1> entersub[t1] KS*/TARG,2
+# j <1> entersub[t1] KS*/TARG,STRICT
# k <1> leavesub[1 ref] K/REFC,1
# BEGIN 3:
# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$
# q <$> const[PV "warnings"] sM
# r <$> const[PV "qw"] sM
# s <$> method_named[PV "unimport"]
-# t <1> entersub[t1] KS*/TARG,2
+# t <1> entersub[t1] KS*/TARG,STRICT
# u <1> leavesub[1 ref] K/REFC,1
# BEGIN 4:
# v <;> nextstate(main 2 -e:1) v:>,<,%,{
# 6 <$> const(PV "strict") sM
# 7 <$> const(PV "refs") sM
# 8 <$> method_named(PV "unimport")
-# 9 <1> entersub[t1] KS*/TARG,2
+# 9 <1> entersub[t1] KS*/TARG,STRICT
# a <1> leavesub[1 ref] K/REFC,1
# BEGIN 2:
# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$
# g <$> const(PV "strict") sM
# h <$> const(PV "refs") sM
# i <$> method_named(PV "unimport")
-# j <1> entersub[t1] KS*/TARG,2
+# j <1> entersub[t1] KS*/TARG,STRICT
# k <1> leavesub[1 ref] K/REFC,1
# BEGIN 3:
# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$
# q <$> const(PV "warnings") sM
# r <$> const(PV "qw") sM
# s <$> method_named(PV "unimport")
-# t <1> entersub[t1] KS*/TARG,2
+# t <1> entersub[t1] KS*/TARG,STRICT
# u <1> leavesub[1 ref] K/REFC,1
# BEGIN 4:
# v <;> nextstate(main 2 -e:1) v:>,<,%,{
# 6 <$> const[PV "strict"] sM
# 7 <$> const[PV "refs"] sM
# 8 <$> method_named[PV "unimport"]
-# 9 <1> entersub[t1] KS*/TARG,2
+# 9 <1> entersub[t1] KS*/TARG,STRICT
# a <1> leavesub[1 ref] K/REFC,1
# BEGIN 2:
# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$
# g <$> const[PV "strict"] sM
# h <$> const[PV "refs"] sM
# i <$> method_named[PV "unimport"]
-# j <1> entersub[t1] KS*/TARG,2
+# j <1> entersub[t1] KS*/TARG,STRICT
# k <1> leavesub[1 ref] K/REFC,1
# BEGIN 3:
# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$
# q <$> const[PV "warnings"] sM
# r <$> const[PV "qw"] sM
# s <$> method_named[PV "unimport"]
-# t <1> entersub[t1] KS*/TARG,2
+# t <1> entersub[t1] KS*/TARG,STRICT
# u <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# BEGIN 1:
# 6 <$> const(PV "strict") sM
# 7 <$> const(PV "refs") sM
# 8 <$> method_named(PV "unimport")
-# 9 <1> entersub[t1] KS*/TARG,2
+# 9 <1> entersub[t1] KS*/TARG,STRICT
# a <1> leavesub[1 ref] K/REFC,1
# BEGIN 2:
# b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$
# g <$> const(PV "strict") sM
# h <$> const(PV "refs") sM
# i <$> method_named(PV "unimport")
-# j <1> entersub[t1] KS*/TARG,2
+# j <1> entersub[t1] KS*/TARG,STRICT
# k <1> leavesub[1 ref] K/REFC,1
# BEGIN 3:
# l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$
# q <$> const(PV "warnings") sM
# r <$> const(PV "qw") sM
# s <$> method_named(PV "unimport")
-# t <1> entersub[t1] KS*/TARG,2
+# t <1> entersub[t1] KS*/TARG,STRICT
# u <1> leavesub[1 ref] K/REFC,1
EONT_EONT
RV = $ADDR
SV = PVCV\\($ADDR\\) at $ADDR
REFCNT = (3|4)
- FLAGS = \\((?:HASEVAL)?\\) # $] < 5.015 || !thr
- FLAGS = \\(DYNFILE(?:,HASEVAL)?\\) # $] >= 5.015 && thr
+ FLAGS = \\((?:HASEVAL(?:,NAMED)?)?\\) # $] < 5.015 || !thr
+ FLAGS = \\(DYNFILE(?:,HASEVAL(?:,NAMED)?)?\\) # $] >= 5.015 && thr
IV = 0 # $] < 5.009
NV = 0 # $] < 5.009
COMP_STASH = $ADDR\\t"main"
ROOT = $ADDR
XSUB = 0x0 # $] < 5.009
XSUBANY = 0 # $] < 5.009
- GVGV::GV = $ADDR\\t"main" :: "do_test"
+ NAME = "do_test" # $] >=5.021004
+ GVGV::GV = $ADDR\\t"main" :: "do_test" # $] < 5.021004
FILE = ".*\\b(?i:peek\\.t)"
DEPTH = 1(?:
MUTEXP = $ADDR
OWNER = $ADDR)?
- FLAGS = 0x(?:400)?0 # $] < 5.015 || !thr
- FLAGS = 0x[145]000 # $] >= 5.015 && thr
+ FLAGS = 0x(?:[c4]00)?0 # $] < 5.015 || !thr
+ FLAGS = 0x[cd145]000 # $] >= 5.015 && thr
OUTSIDE_SEQ = \\d+
PADLIST = $ADDR
PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
NAME = "a"
NAMELEN = 1
GvSTASH = $ADDR\\t"main"
+ FLAGS = $ADDR # $] >=5.021004
GP = $ADDR
SV = $ADDR
REFCNT = 1
CV = 0x0
CVGEN = 0x0
GPFLAGS = 0x0 # $] < 5.009
+ GPFLAGS = 0x0 \(\) # $] >= 5.021004
LINE = \\d+
FILE = ".*\\b(?i:peek\\.t)"
- FLAGS = $ADDR
+ FLAGS = $ADDR # $] < 5.021004
EGV = $ADDR\\t"a"');
if (ord('A') == 193) {
IV = 0 # $] < 5.009
NV = 0 # $] < 5.009
PROTOTYPE = ""
- COMP_STASH = 0x0
+ COMP_STASH = 0x0 # $] < 5.021004
+ COMP_STASH = $ADDR "main" # $] >=5.021004
ROOT = 0x0 # $] < 5.009
XSUB = $ADDR
XSUBANY = $ADDR \\(CONST SV\\)
}
+my $runperl_args = { switches => ['-Ilib'] };
sub test_DumpProg {
my ($prog, $expected, $name, $test) = @_;
$test ||= 'like';
utf8::encode($prog);
if ( $test eq 'is' ) {
- t::fresh_perl_is($prog . $u, $expected, undef, $name)
+ t::fresh_perl_is($prog . $u, $expected, $runperl_args, $name)
}
else {
- t::fresh_perl_like($prog . $u, $expected, undef, $name)
+ t::fresh_perl_like($prog . $u, $expected, $runperl_args, $name)
}
$builder->current_test(t::curr_test() - 1);
1 TYPE = leave ===> NULL
TARG = 1
FLAGS = (VOID,KIDS,PARENS,SLABBED,LASTSIB)
- PRIVATE = (REFCOUNTED)
+ PRIVATE = (REFC)
REFCNT = 1
{
2 TYPE = enter ===> 3
}
{
5 TYPE = entersub ===> 1
- TARG = TARGS_REPLACE
+ TARG = 1
FLAGS = (VOID,KIDS,STACKED,SLABBED,LASTSIB)
- PRIVATE = (HASTARG)
+ PRIVATE = (TARG)
{
6 TYPE = null ===> (5)
(was list)
8 TYPE = null ===> (6)
(was rv2cv)
FLAGS = (SCALAR,KIDS,SLABBED,LASTSIB)
+ PRIVATE = (0x1)
{
7 TYPE = gv ===> 5
FLAGS = (SCALAR,SLABBED,LASTSIB)
}
EODUMP
-$e =~ s/TARGS_REPLACE/$threads ? 3 : 1/e;
$e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg"/e;
+$e =~ s/.*PRIVATE = \(0x1\).*\n// if $] < 5.021004;
test_DumpProg("package t;", $e, "DumpProg() has no 'Attempt to free X prematurely' warning", "is" );
use strict;
use warnings;
use warnings::register;
-our $VERSION = '1.27';
+our $VERSION = '1.28';
require Exporter;
require Cwd;
sub wrap_wanted {
my $wanted = shift;
if ( ref($wanted) eq 'HASH' ) {
+ # RT #122547
+ my %valid_options = map {$_ => 1} qw(
+ wanted
+ bydepth
+ preprocess
+ postprocess
+ follow
+ follow_fast
+ follow_skip
+ dangling_symlinks
+ no_chdir
+ untaint
+ untaint_pattern
+ untaint_skip
+ );
+ my @invalid_options = ();
+ for my $v (keys %{$wanted}) {
+ push @invalid_options, $v unless exists $valid_options{$v};
+ }
+ warn "Invalid option(s): @invalid_options" if @invalid_options;
+
unless( exists $wanted->{wanted} and ref( $wanted->{wanted} ) eq 'CODE' ) {
die 'no &wanted subroutine given';
}
- if ( $wanted->{follow} || $wanted->{follow_fast}) {
- $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip};
- }
- if ( $wanted->{untaint} ) {
- $wanted->{untaint_pattern} = $File::Find::untaint_pattern
- unless defined $wanted->{untaint_pattern};
- $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip};
- }
- return $wanted;
+ if ( $wanted->{follow} || $wanted->{follow_fast}) {
+ $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip};
+ }
+ if ( $wanted->{untaint} ) {
+ $wanted->{untaint_pattern} = $File::Find::untaint_pattern
+ unless defined $wanted->{untaint_pattern};
+ $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip};
+ }
+ return $wanted;
}
elsif( ref( $wanted ) eq 'CODE' ) {
- return { wanted => $wanted };
+ return { wanted => $wanted };
}
else {
die 'no &wanted subroutine given';
}
my $symlink_exists = eval { symlink("",""); 1 };
-my $test_count = 102;
+my $test_count = 109;
$test_count += 127 if $symlink_exists;
$test_count += 26 if $^O eq 'MSWin32';
$test_count += 2 if $^O eq 'MSWin32' and $symlink_exists;
File::Spec->curdir);
is($::count_taint, 1, "'finddepth' found exactly 1 file named 'taint.t'");
+##### RT #122547 #####
+# Do find() and finddepth() correctly warn on invalid options?
+{
+ my $bad_option = 'foobar';
+ my $second_bad_option = 'really_foobar';
+
+ $::count_taint = 0;
+ local $SIG{__WARN__} = sub { $warn_msg = $_[0]; };
+ {
+ find(
+ {
+ wanted => sub { ++$::count_taint if $_ eq 'taint.t'; },
+ $bad_option => undef,
+ },
+ File::Spec->curdir
+ );
+ };
+ like($warn_msg, qr/Invalid option/s, "Got warning for invalid option");
+ like($warn_msg, qr/$bad_option/s, "Got warning for $bad_option");
+ is($::count_taint, 1, "count_taint incremented");
+ undef $warn_msg;
+
+ $::count_taint = 0;
+ {
+ finddepth(
+ {
+ wanted => sub { ++$::count_taint if $_ eq 'taint.t'; },
+ $bad_option => undef,
+ $second_bad_option => undef,
+ },
+ File::Spec->curdir
+ );
+ };
+ like($warn_msg, qr/Invalid option/s, "Got warning for invalid option");
+ like($warn_msg, qr/$bad_option/s, "Got warning for $bad_option");
+ like($warn_msg, qr/$second_bad_option/s, "Got warning for $second_bad_option");
+ is($::count_taint, 1, "count_taint incremented");
+ undef $warn_msg;
+}
+
my $FastFileTests_OK = 0;
sub cleanup {
my @libs;
if ($^O ne 'MSWin32' && $^O ne 'freemint') {
- @libs = ('LIBS' => ["-lm -lposix -lcposix"]);
+ push @libs, qw(m posix cposix);
+}
+if ($^O eq 'solaris') {
+ push @libs, qw(sunmath);
+}
+if ($^O eq 'aix' && $Config{uselongdouble}) {
+ push @libs, qw(c128);
}
WriteMakefile(
NAME => 'POSIX',
- @libs,
+ @libs ? ( 'LIBS' => [ join(" ", map { "-l$_" } @libs) ] ) : (),
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'lib/POSIX.pm',
ABSTRACT_FROM => 'lib/POSIX.pod',
#endif
'});
+push @names,
+ {name=>"INFINITY", type=>"NV", value=>"NV_INF", not_constant=>1},
+ {name=>"NAN", type=>"NV", value=>"NV_NAN", not_constant=>1},
+ {name=>"Inf", type=>"NV", value=>"NV_INF", not_constant=>1},
+ {name=>"NaN", type=>"NV", value=>"NV_NAN", not_constant=>1};
+
push @names, {name=>$_, type=>"UV"}
foreach (qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND
SA_RESTART SA_SIGINFO UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX));
FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX LDBL_DIG LDBL_MANT_DIG
LDBL_MAX_10_EXP LDBL_MAX_EXP LDBL_MIN_10_EXP LDBL_MIN_EXP));
+push @names, {name=>$_, type=>"NV"}
+ foreach (qw(FP_ILOGB0 FP_ILOGBNAN FP_INFINITE FP_NAN FP_NORMAL
+ FP_SUBNORMAL FP_ZERO M_1_PI M_2_PI M_2_SQRTPI M_E M_LN10 M_LN2
+ M_LOG10E M_LOG2E M_PI M_PI_2 M_PI_4 M_SQRT1_2 M_SQRT2));
+
+push @names, {name=>$_, type=>"IV"}
+ foreach (qw(FE_DOWNWARD FE_TONEAREST FE_TOWARDZERO FE_UPWARD));
+
push @names, {name=>$_, type=>"IV", default=>["IV", "0"]}
foreach (qw(_POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_CHOWN_RESTRICTED
_POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT _POSIX_NAME_MAX
#ifdef I_FLOAT
#include <float.h>
#endif
+#ifdef I_FENV
+#include <fenv.h>
+#endif
#ifdef I_LIMITS
#include <limits.h>
#endif
#include <unistd.h>
#endif
+#if defined(USE_QUADMATH) && defined(I_QUADMATH)
+
+# undef M_E
+# undef M_LOG2E
+# undef M_LOG10E
+# undef M_LN2
+# undef M_LN10
+# undef M_PI
+# undef M_PI_2
+# undef M_PI_4
+# undef M_1_PI
+# undef M_2_PI
+# undef M_2_SQRTPI
+# undef M_SQRT2
+# undef M_SQRT1_2
+
+# define M_E M_Eq
+# define M_LOG2E M_LOG2Eq
+# define M_LOG10E M_LOG10Eq
+# define M_LN2 M_LN2q
+# define M_LN10 M_LN10q
+# define M_PI M_PIq
+# define M_PI_2 M_PI_2q
+# define M_PI_4 M_PI_4q
+# define M_1_PI M_1_PIq
+# define M_2_PI M_2_PIq
+# define M_2_SQRTPI M_2_SQRTPIq
+# define M_SQRT2 M_SQRT2q
+# define M_SQRT1_2 M_SQRT1_2q
+
+#else
+
+# ifndef M_E
+# define M_E 2.71828182845904523536028747135266250
+# endif
+# ifndef M_LOG2E
+# define M_LOG2E 1.44269504088896340735992468100189214
+# endif
+# ifndef M_LOG10E
+# define M_LOG10E 0.434294481903251827651128918916605082
+# endif
+# ifndef M_LN2
+# define M_LN2 0.693147180559945309417232121458176568
+# endif
+# ifndef M_LN10
+# define M_LN10 2.30258509299404568401799145468436421
+# endif
+# ifndef M_PI
+# define M_PI 3.14159265358979323846264338327950288
+# endif
+# ifndef M_PI_2
+# define M_PI_2 1.57079632679489661923132169163975144
+# endif
+# ifndef M_PI_4
+# define M_PI_4 0.785398163397448309615660845819875721
+# endif
+# ifndef M_1_PI
+# define M_1_PI 0.318309886183790671537767526745028724
+# endif
+# ifndef M_2_PI
+# define M_2_PI 0.636619772367581343075535053490057448
+# endif
+# ifndef M_2_SQRTPI
+# define M_2_SQRTPI 1.12837916709551257389615890312154517
+# endif
+# ifndef M_SQRT2
+# define M_SQRT2 1.41421356237309504880168872420969808
+# endif
+# ifndef M_SQRT1_2
+# define M_SQRT1_2 0.707106781186547524400844362104849039
+# endif
+
+#endif
+
+#if !defined(INFINITY) && defined(NV_INF)
+# define INFINITY NV_INF
+#endif
+
+#if !defined(NAN) && defined(NV_NAN)
+# define NAN NV_NAN
+#endif
+
+#if !defined(Inf) && defined(NV_INF)
+# define Inf NV_INF
+#endif
+
+#if !defined(NaN) && defined(NV_NAN)
+# define NaN NV_NAN
+#endif
+
+/* We will have an emulation. */
+#ifndef FP_INFINITE
+# define FP_INFINITE 0
+# define FP_NAN 1
+# define FP_NORMAL 2
+# define FP_SUBNORMAL 3
+# define FP_ZERO 4
+#endif
+
+/* We will have an emulation. */
+#ifndef FE_TONEAREST
+# define FE_TONEAREST 0
+# define FE_TOWARDZERO 1
+# define FE_DOWNWARD 2
+# define FE_UPWARD 3
+#endif
+
+/* C89 math.h:
+
+ acos asin atan atan2 ceil cos cosh exp fabs floor fmod frexp ldexp
+ log log10 modf pow sin sinh sqrt tan tanh
+
+ * Implemented in core:
+
+ atan2 cos exp log pow sin sqrt
+
+ * C99 math.h added:
+
+ acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma fmax
+ fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal isinf
+ isless islessequal islessgreater isnan isnormal isunordered lgamma
+ log1p log2 logb lrint lround nan nearbyint nextafter nexttoward remainder
+ remquo rint round scalbn signbit tgamma trunc
+
+ See:
+ http://pubs.opengroup.org/onlinepubs/009695399/basedefs/math.h.html
+
+ * Berkeley/SVID extensions:
+
+ j0 j1 jn y0 y1 yn
+
+ * Configure already (5.21.0) scans for:
+
+ fpclassify isfinite isinf isnan ilogb*l* signbit
+
+ * For floating-point round mode (which matters for e.g. lrint and rint)
+
+ fegetround fesetround
+
+*/
+
+/* XXX Constant FP_FAST_FMA (if true, FMA is faster) */
+
+/* XXX Add ldiv(), lldiv()? It's C99, but from stdlib.h, not math.h */
+
+/* XXX Beware old gamma() -- one cannot know whether that is the
+ * gamma or the log of gamma, that's why the new tgamma and lgamma.
+ * Though also remember tgamma_r and lgamma_r. */
+
+/* XXX The truthiness of acosh() is the canary for all of the
+ * C99 math. This is very likely wrong, especially in non-UNIX lands
+ * like Win32 and VMS, but also older UNIXes have issues. For Win32,
+ * and other non-fully-C99, we later do some undefines for these interfaces.
+ *
+ * But we are very trying very hard to avoid introducing separate Configure
+ * symbols for all the 40-ish new math symbols. Especially since the set
+ * of missing functions doesn't seem to follow any patterns. */
+
+#ifdef HAS_ACOSH
+
+/* Certain AIX releases have the C99 math, but not in long double.
+ * The <math.h> has them, e.g. __expl128, but no library has them!
+ *
+ * See the comments in hints/aix.sh about long doubles.
+ *
+ * AIX 5 releases before 5.3 unknown, AIX releases 7 unknown */
+# if defined(_AIX53) || defined(_AIX61)
+# define NO_C99_LONG_DOUBLE_MATH
+# endif
+
+# if defined(USE_QUADMATH) && defined(I_QUADMATH)
+# define c99_acosh acoshq
+# define c99_asinh asinhq
+# define c99_atanh atanhq
+# define c99_cbrt cbrtq
+# define c99_copysign copysignq
+# define c99_erf erfq
+# define c99_erfc erfcq
+/* no exp2q */
+# define c99_expm1 expm1q
+# define c99_fdim fdimq
+# define c99_fma fmaq
+# define c99_fmax fmaxq
+# define c99_fmin fminq
+# define c99_hypot hypotq
+# define c99_ilogb ilogbq
+# define c99_lgamma lgammaq
+# define c99_log1p log1pq
+# define c99_log2 log2q
+/* no logbq */
+/* no llrintq */
+/* no llroundq */
+# define c99_lrint lrintq
+# define c99_lround lroundq
+# define c99_nan nanq
+# define c99_nearbyint nearbyintq
+# define c99_nextafter nextafterq
+/* no nexttowardq */
+# define c99_remainder remainderq
+# define c99_remquo remquoq
+# define c99_rint rintq
+# define c99_round roundq
+# define c99_scalbn scalbnq
+# define c99_signbit signbitq
+# define c99_tgamma tgammal
+# define c99_trunc truncq
+# define bessel_j0 j0q
+# define bessel_j1 j1q
+# define bessel_jn jnq
+# define bessel_y0 y0q
+# define bessel_y1 y1q
+# define bessel_yn ynq
+# elif defined(USE_LONG_DOUBLE) && \
+ !defined(NO_C99_LONG_DOUBLE_MATH) && \
+ defined(HAS_ILOGBL)
+/* There's already a symbol for ilogbl, we will use its truthiness
+ * as the canary for all the *l variants being defined. */
+# define c99_acosh acoshl
+# define c99_asinh asinhl
+# define c99_atanh atanhl
+# define c99_cbrt cbrtl
+# define c99_copysign copysignl
+# define c99_erf erfl
+# define c99_erfc erfcl
+# define c99_exp2 exp2l
+# define c99_expm1 expm1l
+# define c99_fdim fdiml
+# define c99_fma fmal
+# define c99_fmax fmaxl
+# define c99_fmin fminl
+# define c99_hypot hypotl
+# define c99_ilogb ilogbl
+# define c99_lgamma lgammal
+# define c99_log1p log1pl
+# define c99_log2 log2l
+# define c99_logb logbl
+# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG
+# define c99_lrint llrintl
+# else
+# define c99_lrint lrintl
+# endif
+# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG
+# define c99_lround llroundl
+# else
+# define c99_lround lroundl
+# endif
+# define c99_nan nanl
+# define c99_nearbyint nearbyintl
+# define c99_nextafter nextafterl
+# define c99_nexttoward nexttowardl
+# define c99_remainder remainderl
+# define c99_remquo remquol
+# define c99_rint rintl
+# define c99_round roundl
+# define c99_scalbn scalbnl
+# ifdef HAS_SIGNBIT /* possibly bad assumption */
+# define c99_signbit signbitl
+# endif
+# define c99_tgamma tgammal
+# define c99_trunc truncl
+# else
+# define c99_acosh acosh
+# define c99_asinh asinh
+# define c99_atanh atanh
+# define c99_cbrt cbrt
+# define c99_copysign copysign
+# define c99_erf erf
+# define c99_erfc erfc
+# define c99_exp2 exp2
+# define c99_expm1 expm1
+# define c99_fdim fdim
+# define c99_fma fma
+# define c99_fmax fmax
+# define c99_fmin fmin
+# define c99_hypot hypot
+# define c99_ilogb ilogb
+# define c99_lgamma lgamma
+# define c99_log1p log1p
+# define c99_log2 log2
+# define c99_logb logb
+# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG
+# define c99_lrint llrint
+# else
+# define c99_lrint lrint
+# endif
+# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG
+# define c99_lround llround
+# else
+# define c99_lround lround
+# endif
+# define c99_nan nan
+# define c99_nearbyint nearbyint
+# define c99_nextafter nextafter
+# define c99_nexttoward nexttoward
+# define c99_remainder remainder
+# define c99_remquo remquo
+# define c99_rint rint
+# define c99_round round
+# define c99_scalbn scalbn
+/* We already define Perl_signbit in perl.h. */
+# ifdef HAS_SIGNBIT
+# define c99_signbit signbit
+# endif
+# define c99_tgamma tgamma
+# define c99_trunc trunc
+# endif
+
+# ifndef isunordered
+# ifdef Perl_isnan
+# define isunordered(x, y) (Perl_isnan(x) || Perl_isnan(y))
+# elif defined(HAS_UNORDERED)
+# define isunordered(x, y) unordered(x, y)
+# endif
+# endif
+
+# if !defined(isgreater) && defined(isunordered)
+# define isgreater(x, y) (!isunordered((x), (y)) && (x) > (y))
+# define isgreaterequal(x, y) (!isunordered((x), (y)) && (x) >= (y))
+# define isless(x, y) (!isunordered((x), (y)) && (x) < (y))
+# define islessequal(x, y) (!isunordered((x), (y)) && (x) <= (y))
+# define islessgreater(x, y) (!isunordered((x), (y)) && \
+ ((x) > (y) || (y) > (x)))
+# endif
+
+/* Check both the Configure symbol and the macro-ness (like C99 promises). */
+# if defined(HAS_FPCLASSIFY) && defined(fpclassify)
+# define c99_fpclassify fpclassify
+# endif
+/* Like isnormal(), the isfinite(), isinf(), and isnan() are also C99
+ and also (sizeof-arg-aware) macros, but they are already well taken
+ care of by Configure et al, and defined in perl.h as
+ Perl_isfinite(), Perl_isinf(), and Perl_isnan(). */
+# ifdef isnormal
+# define c99_isnormal isnormal
+# endif
+# ifdef isgreater /* canary for all the C99 is*<cmp>* macros. */
+# define c99_isgreater isgreater
+# define c99_isgreaterequal isgreaterequal
+# define c99_isless isless
+# define c99_islessequal islessequal
+# define c99_islessgreater islessgreater
+# define c99_isunordered isunordered
+# endif
+#endif
+
+/* If on legacy platforms, and not using gcc, some C99 math interfaces
+ * might be missing, turn them off so that the emulations hopefully
+ * kick in. This is admittedly nasty, and fragile, but the alternative
+ * is to have Configure scans for all the 40+ interfaces.
+ *
+ * For some platforms, also the gcc implementations are missing
+ * certain interfaces.
+ *
+ * In other words: if you have an incomplete (or broken) C99 math interface,
+ * #undef the c99_foo here, and let the emulations kick in. */
+
+#ifdef __GNUC__
+
+/* using gcc */
+
+# if defined(__hpux) && (defined(__hppa) || defined(_PA_RISC))
+# undef c99_nexttoward
+# undef c99_tgamma
+# endif
+
+#else
+
+/* not using gcc */
+
+# if defined(_AIX53) || defined(_AIX61) /* AIX 7 has nexttoward */
+# undef c99_nexttoward
+# endif
+
+/* HP-UX on PA-RISC is missing certain C99 math functions,
+ * but on IA64 (Integrity) these do exist, and even on
+ * recent enough HP-UX (cc) releases. */
+# if defined(__hpux) && (defined(__hppa) || defined(_PA_RISC))
+/* lowest known release, could be lower */
+# if defined(__HP_cc) && __HP_cc >= 111120
+# undef c99_fma
+# undef c99_nexttoward
+# undef c99_tgamma
+# else
+# undef c99_exp2
+# undef c99_fdim
+# undef c99_fma
+# undef c99_fmax
+# undef c99_fmin
+# undef c99_fpclassify /* hpux 10.20 has fpclassify but different api */
+# undef c99_lrint
+# undef c99_lround
+# undef c99_nan
+# undef c99_nearbyint
+# undef c99_nexttoward
+# undef c99_remquo
+# undef c99_round
+# undef c99_scalbn
+# undef c99_tgamma
+# undef c99_trunc
+# endif
+# endif
+
+# if defined(__irix__)
+# undef c99_ilogb
+# undef c99_exp2
+# endif
+
+# if defined(__osf__) /* Tru64 */
+# undef c99_fdim
+# undef c99_fma
+# undef c99_fmax
+# undef c99_fmin
+# undef c99_fpclassify
+# undef c99_isfinite
+# undef c99_isinf
+# undef c99_isunordered
+# undef c99_lrint
+# undef c99_lround
+# undef c99_nearbyint
+# undef c99_nexttoward
+# undef c99_remquo
+# undef c99_round
+# undef c99_scalbn
+# endif
+
+#endif
+
+/* XXX Regarding C99 math.h, VMS seems to be missing these:
+
+ lround nan nearbyint round scalbn llrint
+ */
+
+#ifdef __VMS
+# undef c99_lround
+# undef c99_nan
+# undef c99_nearbyint
+# undef c99_round
+# undef c99_scalbn
+/* Have lrint but not llrint. */
+# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG
+# undef c99_lrint
+# endif
+#endif
+
+/* XXX Regarding C99 math.h, Win32 seems to be missing these:
+
+ erf erfc exp2 fdim fma fmax fmin fpclassify ilogb lgamma log1p log2 lrint
+ remquo rint signbit tgamma trunc
+
+ Win32 does seem to have these:
+
+ acosh asinh atanh cbrt copysign cosh expm1 hypot log10 nan
+ nearbyint nextafter nexttoward remainder round scalbn
+
+ And the Bessel functions are defined like _this.
+*/
+
+#ifdef WIN32
+# undef c99_erf
+# undef c99_erfc
+# undef c99_exp2
+# undef c99_fdim
+# undef c99_fma
+# undef c99_fmax
+# undef c99_fmin
+# undef c99_ilogb
+# undef c99_lgamma
+# undef c99_log1p
+# undef c99_log2
+# undef c99_lrint
+# undef c99_lround
+# undef c99_remquo
+# undef c99_rint
+# undef c99_signbit
+# undef c99_tgamma
+# undef c99_trunc
+
+/* Some APIs exist under Win32 with "underbar" names. */
+# undef c99_hypot
+# undef c99_logb
+# undef c99_nextafter
+# define c99_hypot _hypot
+# define c99_logb _logb
+# define c99_nextafter _nextafter
+
+# define bessel_j0 _j0
+# define bessel_j1 _j1
+# define bessel_jn _jn
+# define bessel_y0 _y0
+# define bessel_y1 _y1
+# define bessel_yn _yn
+
+#endif
+
+#ifdef __CYGWIN__
+# undef c99_nexttoward
+#endif
+
+/* The Bessel functions: BSD, SVID, XPG4, and POSIX. But not C99. */
+#if defined(HAS_J0) && !defined(bessel_j0)
+# if defined(USE_LONG_DOUBLE) && defined(HAS_J0L)
+# define bessel_j0 j0l
+# define bessel_j1 j1l
+# define bessel_jn jnl
+# define bessel_y0 y0l
+# define bessel_y1 y1l
+# define bessel_yn ynl
+# else
+# define bessel_j0 j0
+# define bessel_j1 j1
+# define bessel_jn jn
+# define bessel_y0 y0
+# define bessel_y1 y1
+# define bessel_yn yn
+# endif
+#endif
+
+/* Emulations for missing math APIs.
+ *
+ * Keep in mind that the point of many of these functions is that
+ * they, if available, are supposed to give more precise/more
+ * numerically stable results.
+ *
+ * See e.g. http://www.johndcook.com/math_h.html
+ */
+
+#ifndef c99_acosh
+static NV my_acosh(NV x)
+{
+ return Perl_log(x + Perl_sqrt(x * x - 1));
+}
+# define c99_acosh my_acosh
+#endif
+
+#ifndef c99_asinh
+static NV my_asinh(NV x)
+{
+ return Perl_log(x + Perl_sqrt(x * x + 1));
+}
+# define c99_asinh my_asinh
+#endif
+
+#ifndef c99_atanh
+static NV my_atanh(NV x)
+{
+ return (Perl_log(1 + x) - Perl_log(1 - x)) / 2;
+}
+# define c99_atanh my_atanh
+#endif
+
+#ifndef c99_cbrt
+static NV my_cbrt(NV x)
+{
+ static const NV one_third = (NV)1.0/3;
+ return x >= 0.0 ? Perl_pow(x, one_third) : -Perl_pow(-x, one_third);
+}
+# define c99_cbrt my_cbrt
+#endif
+
+#ifndef c99_copysign
+static NV my_copysign(NV x, NV y)
+{
+ return y >= 0 ? (x < 0 ? -x : x) : (x < 0 ? x : -x);
+}
+# define c99_copysign my_copysign
+#endif
+
+/* XXX cosh (though c89) */
+
+#ifndef c99_erf
+static NV my_erf(NV x)
+{
+ /* http://www.johndcook.com/cpp_erf.html -- public domain */
+ NV a1 = 0.254829592;
+ NV a2 = -0.284496736;
+ NV a3 = 1.421413741;
+ NV a4 = -1.453152027;
+ NV a5 = 1.061405429;
+ NV p = 0.3275911;
+ NV t, y;
+ int sign = x < 0 ? -1 : 1; /* Save the sign. */
+ x = PERL_ABS(x);
+
+ /* Abramowitz and Stegun formula 7.1.26 */
+ t = 1.0 / (1.0 + p * x);
+ y = 1.0 - (((((a5*t + a4)*t) + a3)*t + a2)*t + a1) * t * Perl_exp(-x*x);
+
+ return sign * y;
+}
+# define c99_erf my_erf
+#endif
+
+#ifndef c99_erfc
+static NV my_erfc(NV x) {
+ /* This is not necessarily numerically stable, but better than nothing. */
+ return 1.0 - c99_erf(x);
+}
+# define c99_erfc my_erfc
+#endif
+
+#ifndef c99_exp2
+static NV my_exp2(NV x)
+{
+ return Perl_pow((NV)2.0, x);
+}
+# define c99_exp2 my_exp2
+#endif
+
+#ifndef c99_expm1
+static NV my_expm1(NV x)
+{
+ if (PERL_ABS(x) < 1e-5)
+ /* http://www.johndcook.com/cpp_expm1.html -- public domain.
+ * Taylor series, the first four terms (the last term quartic). */
+ /* Probably not enough for long doubles. */
+ return x * (1.0 + x * (1/2.0 + x * (1/6.0 + x/24.0)));
+ else
+ return Perl_exp(x) - 1;
+}
+# define c99_expm1 my_expm1
+#endif
+
+#ifndef c99_fdim
+static NV my_fdim(NV x, NV y)
+{
+ return x > y ? x - y : 0;
+}
+# define c99_fdim my_fdim
+#endif
+
+#ifndef c99_fmax
+static NV my_fmax(NV x, NV y)
+{
+ if (Perl_isnan(x)) {
+ return Perl_isnan(y) ? NV_NAN : y;
+ } else if (Perl_isnan(y)) {
+ return x;
+ }
+ return x > y ? x : y;
+}
+# define c99_fmax my_fmax
+#endif
+
+#ifndef c99_fmin
+static NV my_fmin(NV x, NV y)
+{
+ if (Perl_isnan(x)) {
+ return Perl_isnan(y) ? NV_NAN : y;
+ } else if (Perl_isnan(y)) {
+ return x;
+ }
+ return x < y ? x : y;
+}
+# define c99_fmin my_fmin
+#endif
+
+#ifndef c99_fpclassify
+
+static IV my_fpclassify(NV x)
+{
+#ifdef Perl_fp_class_inf
+ if (Perl_fp_class_inf(x)) return FP_INFINITE;
+ if (Perl_fp_class_nan(x)) return FP_NAN;
+ if (Perl_fp_class_norm(x)) return FP_NORMAL;
+ if (Perl_fp_class_denorm(x)) return FP_SUBNORMAL;
+ if (Perl_fp_class_zero(x)) return FP_ZERO;
+# define c99_fpclassify my_fpclassify
+#endif
+ return -1;
+}
+
+#endif
+
+#ifndef c99_hypot
+static NV my_hypot(NV x, NV y)
+{
+ /* http://en.wikipedia.org/wiki/Hypot */
+ NV t;
+ x = PERL_ABS(x); /* Take absolute values. */
+ if (y == 0)
+ return x;
+ if (Perl_isnan(y))
+ return NV_INF;
+ y = PERL_ABS(y);
+ if (x < y) { /* Swap so that y is less. */
+ t = x;
+ x = y;
+ y = t;
+ }
+ t = y / x;
+ return x * Perl_sqrt(1.0 + t * t);
+}
+# define c99_hypot my_hypot
+#endif
+
+#ifndef c99_ilogb
+static IV my_ilogb(NV x)
+{
+ return (IV)(Perl_log(x) * M_LOG2E);
+}
+# define c99_ilogb my_ilogb
+#endif
+
+/* XXX lgamma -- non-trivial */
+
+#ifndef c99_log1p
+static NV my_log1p(NV x)
+{
+ /* http://www.johndcook.com/cpp_log_one_plus_x.html -- public domain.
+ * Taylor series, the first four terms (the last term quartic). */
+ if (x < -1.0)
+ return NV_NAN;
+ if (x == -1.0)
+ return -NV_INF;
+ if (PERL_ABS(x) > 1e-4)
+ return Perl_log(1.0 + x);
+ else
+ /* Probably not enough for long doubles. */
+ return x * (1.0 + x * (-1/2.0 + x * (1/3.0 - x/4.0)));
+}
+# define c99_log1p my_log1p
+#endif
+
+#ifndef c99_log2
+static NV my_log2(NV x)
+{
+ return Perl_log(x) * M_LOG2E;
+}
+# define c99_log2 my_log2
+#endif
+
+/* XXX nextafter */
+
+/* XXX nexttoward */
+
+static int my_fegetround()
+{
+#ifdef HAS_FEGETROUND
+ return fegetround();
+#elif defined(FLT_ROUNDS)
+ return FLT_ROUNDS;
+#elif defined(HAS_FPGETROUND)
+ switch (fpgetround()) {
+ default:
+ case FP_RN: return FE_TONEAREST;
+ case FP_RZ: return FE_TOWARDZERO;
+ case FP_RM: return FE_DOWNWARD;
+ case FE_RP: return FE_UPWARD;
+ }
+#else
+ return -1;
+#endif
+}
+
+/* Toward closest integer. */
+#define MY_ROUND_NEAREST(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x) - 0.5)))
+
+/* Toward zero. */
+#define MY_ROUND_TRUNC(x) ((NV)((IV)(x)))
+
+/* Toward minus infinity. */
+#define MY_ROUND_DOWN(x) ((NV)((IV)((x) >= 0.0 ? (x) : (x) - 0.5)))
+
+/* Toward plus infinity. */
+#define MY_ROUND_UP(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x))))
+
+static NV my_rint(NV x)
+{
+#ifdef FE_TONEAREST
+ switch (my_fegetround()) {
+ default:
+ case FE_TONEAREST: return MY_ROUND_NEAREST(x);
+ case FE_TOWARDZERO: return MY_ROUND_TRUNC(x);
+ case FE_DOWNWARD: return MY_ROUND_DOWN(x);
+ case FE_UPWARD: return MY_ROUND_UP(x);
+ }
+#elif defined(HAS_FPGETROUND)
+ switch (fpgetround()) {
+ default:
+ case FP_RN: return MY_ROUND_NEAREST(x);
+ case FP_RZ: return MY_ROUND_TRUNC(x);
+ case FP_RM: return MY_ROUND_DOWN(x);
+ case FE_RP: return MY_ROUND_UP(x);
+ }
+#else
+ return NV_NAN;
+#endif
+}
+
+/* XXX nearbyint() and rint() are not really identical -- but the difference
+ * is messy: nearbyint is defined NOT to raise FE_INEXACT floating point
+ * exceptions, while rint() is defined to MAYBE raise them. At the moment
+ * Perl is blissfully unaware of such fine detail of floating point. */
+#ifndef c99_nearbyint
+# ifdef FE_TONEAREST
+# define c99_nearbyrint my_rint
+# endif
+#endif
+
+#ifndef c99_lrint
+# ifdef FE_TONEAREST
+static IV my_lrint(NV x)
+{
+ return (IV)my_rint(x);
+}
+# define c99_lrint my_lrint
+# endif
+#endif
+
+#ifndef c99_lround
+static IV my_lround(NV x)
+{
+ return (IV)MY_ROUND_NEAREST(x);
+}
+# define c99_lround my_lround
+#endif
+
+/* XXX remainder */
+
+/* XXX remquo */
+
+#ifndef c99_rint
+# ifdef FE_TONEAREST
+# define c99_rint my_rint
+# endif
+#endif
+
+#ifndef c99_round
+static NV my_round(NV x)
+{
+ return MY_ROUND_NEAREST(x);
+}
+# define c99_round my_round
+#endif
+
+#ifndef c99_scalbn
+# if defined(Perl_ldexp) && FLT_RADIX == 2
+static NV my_scalbn(NV x, int y)
+{
+ return Perl_ldexp(x, y);
+}
+# define c99_scalbn my_scalbn
+# endif
+#endif
+
+/* XXX sinh (though c89) */
+
+#ifndef c99_tgamma
+# ifdef c99_lgamma
+static NV my_tgamma(NV x)
+{
+ double l = c99_lgamma(x);
+ return signgam * Perl_exp(l); /* XXX evil global signgam, need lgamma_r */
+}
+# define c99_tgamma my_tgamma
+/* XXX tgamma without lgamma -- non-trivial */
+# endif
+#endif
+
+/* XXX tanh (though c89) */
+
+#ifndef c99_trunc
+static NV my_trunc(NV x)
+{
+ return MY_ROUND_TRUNC(x);
+}
+# define c99_trunc my_trunc
+#endif
+
/* XXX This comment is just to make I_TERMIO and I_SGTTY visible to
metaconfig for future extension writers. We don't use them in POSIX.
(This is really sneaky :-) --AD
# define setuid(a) not_here("setuid")
# define setgid(a) not_here("setgid")
#endif /* NETWARE */
+# define strtold(s1,s2) not_here("strtold")
#else
# ifndef HAS_MKFIFO
double strtod (const char *, char **);
long strtol (const char *, char **, int);
unsigned long strtoul (const char *, char **, int);
+#ifdef HAS_STRTOLD
+long double strtold (const char *, char **);
+#endif
END_EXTERN_C
#endif
#ifndef HAS_STRTOD
#define strtod(s1,s2) not_here("strtod")
#endif
+#ifndef HAS_STRTOLD
+#define strtold(s1,s2) not_here("strtold")
+#endif
#ifndef HAS_STRTOL
#define strtol(s1,s2,b) not_here("strtol")
#endif
acos(x)
NV x
ALIAS:
- asin = 1
- atan = 2
- ceil = 3
- cosh = 4
- floor = 5
- log10 = 6
- sinh = 7
- tan = 8
- tanh = 9
+ acosh = 1
+ asin = 2
+ asinh = 3
+ atan = 4
+ atanh = 5
+ cbrt = 6
+ ceil = 7
+ cosh = 8
+ erf = 9
+ erfc = 10
+ exp2 = 11
+ expm1 = 12
+ floor = 13
+ j0 = 14
+ j1 = 15
+ lgamma = 16
+ log10 = 17
+ log1p = 18
+ log2 = 19
+ logb = 20
+ nearbyint = 21
+ rint = 22
+ round = 23
+ sinh = 24
+ tan = 25
+ tanh = 26
+ tgamma = 27
+ trunc = 28
+ y0 = 29
+ y1 = 30
CODE:
+ RETVAL = NV_NAN;
switch (ix) {
case 0:
- RETVAL = acos(x);
+ RETVAL = Perl_acos(x); /* C89 math */
break;
case 1:
- RETVAL = asin(x);
+#ifdef c99_acosh
+ RETVAL = c99_acosh(x);
+#else
+ not_here("acosh");
+#endif
break;
case 2:
- RETVAL = atan(x);
+ RETVAL = Perl_asin(x); /* C89 math */
break;
case 3:
- RETVAL = ceil(x);
+#ifdef c99_asinh
+ RETVAL = c99_asinh(x);
+#else
+ not_here("asinh");
+#endif
break;
case 4:
- RETVAL = cosh(x);
+ RETVAL = Perl_atan(x); /* C89 math */
break;
case 5:
- RETVAL = floor(x);
+#ifdef c99_atanh
+ RETVAL = c99_atanh(x);
+#else
+ not_here("atanh");
+#endif
break;
case 6:
- RETVAL = log10(x);
+#ifdef c99_cbrt
+ RETVAL = c99_cbrt(x);
+#else
+ not_here("cbrt");
+#endif
break;
case 7:
- RETVAL = sinh(x);
+ RETVAL = Perl_ceil(x); /* C89 math */
break;
case 8:
- RETVAL = tan(x);
+ RETVAL = Perl_cosh(x); /* C89 math */
+ break;
+ case 9:
+#ifdef c99_erf
+ RETVAL = c99_erf(x);
+#else
+ not_here("erf");
+#endif
+ break;
+ case 10:
+#ifdef c99_erfc
+ RETVAL = c99_erfc(x);
+#else
+ not_here("erfc");
+#endif
+ break;
+ case 11:
+#ifdef c99_exp2
+ RETVAL = c99_exp2(x);
+#else
+ not_here("exp2");
+#endif
+ break;
+ case 12:
+#ifdef c99_expm1
+ RETVAL = c99_expm1(x);
+#else
+ not_here("expm1");
+#endif
+ break;
+ case 13:
+ RETVAL = Perl_floor(x); /* C89 math */
+ break;
+ case 14:
+#ifdef bessel_j0
+ RETVAL = bessel_j0(x);
+#else
+ not_here("j0");
+#endif
+ break;
+ case 15:
+#ifdef bessel_j1
+ RETVAL = bessel_j1(x);
+#else
+ not_here("j1");
+#endif
+ break;
+ case 16:
+ /* XXX lgamma_r -- the lgamma accesses a global variable (signgam),
+ * which is evil. Some platforms have lgamma_r, which has
+ * extra parameter instead of the global variable. */
+#ifdef c99_lgamma
+ RETVAL = c99_lgamma(x);
+#else
+ not_here("lgamma");
+#endif
+ break;
+ case 17:
+ RETVAL = log10(x); /* C89 math */
+ break;
+ case 18:
+#ifdef c99_log1p
+ RETVAL = c99_log1p(x);
+#else
+ not_here("log1p");
+#endif
+ break;
+ case 19:
+#ifdef c99_log2
+ RETVAL = c99_log2(x);
+#else
+ not_here("log2");
+#endif
+ break;
+ case 20:
+#ifdef c99_logb
+ RETVAL = c99_logb(x);
+#else
+ not_here("logb");
+#endif
+ break;
+ case 21:
+#ifdef c99_nearbyint
+ RETVAL = c99_nearbyint(x);
+#else
+ not_here("nearbyint");
+#endif
+ break;
+ case 22:
+#ifdef c99_rint
+ RETVAL = c99_rint(x);
+#else
+ not_here("rint");
+#endif
+ break;
+ case 23:
+#ifdef c99_round
+ RETVAL = c99_round(x);
+#else
+ not_here("round");
+#endif
+ break;
+ case 24:
+ RETVAL = Perl_sinh(x); /* C89 math */
+ break;
+ case 25:
+ RETVAL = Perl_tan(x); /* C89 math */
+ break;
+ case 26:
+ RETVAL = Perl_tanh(x); /* C89 math */
+ break;
+ case 27:
+ /* XXX tgamma_r -- the lgamma accesses a global variable (signgam),
+ * which is evil. Some platforms have tgamma_r, which has
+ * extra parameter instead of the global variable. */
+#ifdef c99_tgamma
+ RETVAL = c99_tgamma(x);
+#else
+ not_here("tgamma");
+#endif
+ break;
+ case 28:
+#ifdef c99_trunc
+ RETVAL = c99_trunc(x);
+#else
+ not_here("trunc");
+#endif
break;
+ case 29:
+#ifdef bessel_y0
+ RETVAL = bessel_y0(x);
+#else
+ not_here("y0");
+#endif
+ break;
+ case 30:
+ default:
+#ifdef bessel_y1
+ RETVAL = bessel_y1(x);
+#else
+ not_here("y1");
+#endif
+ }
+ OUTPUT:
+ RETVAL
+
+IV
+fegetround()
+ CODE:
+#ifdef HAS_FEGETROUND
+ RETVAL = my_fegetround();
+#else
+ RETVAL = -1;
+ not_here("fegetround");
+#endif
+ OUTPUT:
+ RETVAL
+
+IV
+fesetround(x)
+ IV x
+ CODE:
+#ifdef HAS_FEGETROUND /* canary for fesetround */
+ RETVAL = fesetround(x);
+#elif defined(HAS_FPGETROUND) /* canary for fpsetround */
+ switch (x) {
+ default:
+ case FE_TONEAREST: RETVAL = fpsetround(FP_RN); break;
+ case FE_TOWARDZERO: RETVAL = fpsetround(FP_RZ); break;
+ case FE_DOWNWARD: RETVAL = fpsetround(FP_RM); break;
+ case FE_UPWARD: RETVAL = fpsetround(FP_RP); break;
+ }
+#else
+ RETVAL = -1;
+ not_here("fesetround");
+#endif
+ OUTPUT:
+ RETVAL
+
+IV
+fpclassify(x)
+ NV x
+ ALIAS:
+ ilogb = 1
+ isfinite = 2
+ isinf = 3
+ isnan = 4
+ isnormal = 5
+ lrint = 6
+ lround = 7
+ signbit = 8
+ CODE:
+ RETVAL = -1;
+ switch (ix) {
+ case 0:
+#ifdef c99_fpclassify
+ RETVAL = c99_fpclassify(x);
+#else
+ not_here("fpclassify");
+#endif
+ break;
+ case 1:
+#ifdef c99_ilogb
+ RETVAL = c99_ilogb(x);
+#else
+ not_here("ilogb");
+#endif
+ break;
+ case 2:
+ RETVAL = Perl_isfinite(x);
+ break;
+ case 3:
+ RETVAL = Perl_isinf(x);
+ break;
+ case 4:
+ RETVAL = Perl_isnan(x);
+ break;
+ case 5:
+#ifdef c99_isnormal
+ RETVAL = c99_isnormal(x);
+#else
+ not_here("isnormal");
+#endif
+ break;
+ case 6:
+#ifdef c99_lrint
+ RETVAL = c99_lrint(x);
+#else
+ not_here("lrint");
+#endif
+ break;
+ case 7:
+#ifdef c99_lround
+ RETVAL = c99_lround(x);
+#else
+ not_here("lround");
+#endif
+ break;
+ case 8:
default:
- RETVAL = tanh(x);
+#ifdef Perl_signbit
+ RETVAL = Perl_signbit(x);
+#endif
+ break;
}
OUTPUT:
RETVAL
NV
-fmod(x,y)
+copysign(x,y)
NV x
NV y
+ ALIAS:
+ fdim = 1
+ fmax = 2
+ fmin = 3
+ fmod = 4
+ hypot = 5
+ isgreater = 6
+ isgreaterequal = 7
+ isless = 8
+ islessequal = 9
+ islessgreater = 10
+ isunordered = 11
+ nextafter = 12
+ nexttoward = 13
+ remainder = 14
+ CODE:
+ RETVAL = NV_NAN;
+ switch (ix) {
+ case 0:
+#ifdef c99_copysign
+ RETVAL = c99_copysign(x, y);
+#else
+ not_here("copysign");
+#endif
+ break;
+ case 1:
+#ifdef c99_fdim
+ RETVAL = c99_fdim(x, y);
+#else
+ not_here("fdim");
+#endif
+ break;
+ case 2:
+#ifdef c99_fmax
+ RETVAL = c99_fmax(x, y);
+#else
+ not_here("fmax");
+#endif
+ break;
+ case 3:
+#ifdef c99_fmin
+ RETVAL = c99_fmin(x, y);
+#else
+ not_here("fmin");
+#endif
+ break;
+ case 4:
+ RETVAL = Perl_fmod(x, y); /* C89 math */
+ break;
+ case 5:
+#ifdef c99_hypot
+ RETVAL = c99_hypot(x, y);
+#else
+ not_here("hypot");
+#endif
+ break;
+ case 6:
+#ifdef c99_isgreater
+ RETVAL = c99_isgreater(x, y);
+#else
+ not_here("isgreater");
+#endif
+ break;
+ case 7:
+#ifdef c99_isgreaterequal
+ RETVAL = c99_isgreaterequal(x, y);
+#else
+ not_here("isgreaterequal");
+#endif
+ break;
+ case 8:
+#ifdef c99_isless
+ RETVAL = c99_isless(x, y);
+#else
+ not_here("isless");
+#endif
+ break;
+ case 9:
+#ifdef c99_islessequal
+ RETVAL = c99_islessequal(x, y);
+#else
+ not_here("islessequal");
+#endif
+ break;
+ case 10:
+#ifdef c99_islessgreater
+ RETVAL = c99_islessgreater(x, y);
+#else
+ not_here("islessgreater");
+#endif
+ break;
+ case 11:
+#ifdef c99_isunordered
+ RETVAL = c99_isunordered(x, y);
+#else
+ not_here("isunordered");
+#endif
+ break;
+ case 12:
+#ifdef c99_nextafter
+ RETVAL = c99_nextafter(x, y);
+#else
+ not_here("nextafter");
+#endif
+ break;
+ case 13:
+#ifdef c99_nexttoward
+ RETVAL = c99_nexttoward(x, y);
+#else
+ not_here("nexttoward");
+#endif
+ break;
+ case 14:
+ default:
+#ifdef c99_remainder
+ RETVAL = c99_remainder(x, y);
+#else
+ not_here("remainder");
+#endif
+ break;
+ }
+ OUTPUT:
+ RETVAL
void
frexp(x)
PPCODE:
int expvar;
/* (We already know stack is long enough.) */
- PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar))));
+ PUSHs(sv_2mortal(newSVnv(Perl_frexp(x,&expvar)))); /* C89 math */
PUSHs(sv_2mortal(newSViv(expvar)));
NV
PPCODE:
NV intvar;
/* (We already know stack is long enough.) */
- PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar))));
+ PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); /* C89 math */
PUSHs(sv_2mortal(newSVnv(intvar)));
+void
+remquo(x,y)
+ NV x
+ NV y
+ PPCODE:
+#ifdef c99_remquo
+ int intvar;
+ PUSHs(sv_2mortal(newSVnv(c99_remquo(x,y,&intvar))));
+ PUSHs(sv_2mortal(newSVnv(intvar)));
+#else
+ not_here("remquo");
+#endif
+
+NV
+scalbn(x,y)
+ NV x
+ IV y
+ CODE:
+#ifdef c99_scalbn
+ RETVAL = c99_scalbn(x, y);
+#else
+ RETVAL = NV_NAN;
+ not_here("scalbn");
+#endif
+ OUTPUT:
+ RETVAL
+
+NV
+fma(x,y,z)
+ NV x
+ NV y
+ NV z
+ CODE:
+#ifdef c99_fma
+ RETVAL = c99_fma(x, y, z);
+#else
+ RETVAL = NV_NAN;
+ not_here("fma");
+#endif
+ OUTPUT:
+ RETVAL
+
+NV
+nan(s = 0)
+ char* s;
+ CODE:
+#ifdef c99_nan
+ RETVAL = c99_nan(s ? s : "");
+#else
+ RETVAL = NV_NAN;
+# ifndef NV_NAN
+ not_here("nan");
+# endif
+#endif
+ OUTPUT:
+ RETVAL
+
+NV
+jn(x,y)
+ IV x
+ NV y
+ ALIAS:
+ yn = 1
+ CODE:
+ RETVAL = NV_NAN;
+ switch (ix) {
+ case 0:
+#ifdef bessel_jn
+ RETVAL = bessel_jn(x, y);
+#else
+ not_here("jn");
+#endif
+ break;
+ case 1:
+ default:
+#ifdef bessel_yn
+ RETVAL = bessel_yn(x, y);
+#else
+ not_here("yn");
+#endif
+ break;
+ }
+ OUTPUT:
+ RETVAL
+
SysRet
sigaction(sig, optaction, oldaction = 0)
int sig
}
RESTORE_NUMERIC_STANDARD();
+#ifdef HAS_STRTOLD
+
+void
+strtold(str)
+ char * str
+ PREINIT:
+ long double num;
+ char *unparsed;
+ PPCODE:
+ STORE_NUMERIC_STANDARD_FORCE_LOCAL();
+ num = strtold(str, &unparsed);
+ PUSHs(sv_2mortal(newSVnv(num)));
+ if (GIMME == G_ARRAY) {
+ EXTEND(SP, 1);
+ if (unparsed)
+ PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
+ else
+ PUSHs(&PL_sv_undef);
+ }
+ RESTORE_NUMERIC_STANDARD();
+
+#endif
+
void
strtol(str, base = 0)
char * str
our ($AUTOLOAD, %SIGRT);
-our $VERSION = '1.42';
+our $VERSION = '1.43';
require XSLoader;
S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID
S_IWGRP S_IWOTH S_IWUSR)],
+ fenv_h => [qw(FE_DOWNWARD FE_TONEAREST FE_TOWARDZERO FE_UPWARD
+ fegetround fesetround)],
+
float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG
DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP
DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP
LC_MONETARY LC_NUMERIC LC_TIME NULL
localeconv setlocale)],
- math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod
- frexp ldexp log10 modf pow sinh tan tanh)],
+ math_h => [qw(FP_ILOGB0 FP_ILOGBNAN FP_INFINITE FP_NAN FP_NORMAL
+ FP_SUBNORMAL FP_ZERO HUGE_VAL INFINITY Inf M_1_PI
+ M_2_PI M_2_SQRTPI M_E M_LN10 M_LN2 M_LOG10E M_LOG2E M_PI
+ M_PI_2 M_PI_4 M_SQRT1_2 M_SQRT2 NAN NaN acos acosh
+ asin asinh atan atanh cbrt ceil copysign cosh erf
+ erfc exp2 expm1 fabs fdim floor fma fmax fmin fmod
+ fpclassify frexp hypot ilogb isfinite isgreater
+ isgreaterequal isinf isless islessequal
+ islessgreater isnan isnormal isunordered j0 j1 jn
+ ldexp lgamma log10 log1p log2 logb lrint modf nan
+ nearbyint nextafter nexttoward pow remainder remquo
+ rint round scalbn signbit sinh tan tanh tgamma trunc
+ y0 y1 yn)],
pwd_h => [],
stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX
abort atexit atof atoi atol bsearch calloc div
free getenv labs ldiv malloc mblen mbstowcs mbtowc
- qsort realloc strtod strtol strtoul wcstombs wctomb)],
+ qsort realloc strtod strtol strtold strtoul wcstombs wctomb)],
string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat
strchr strcmp strcoll strcpy strcspn strerror strlen
constants and macros in an organization which roughly follows IEEE Std
1003.1b-1993.
+=head1 C99 "math" interfaces
+
+Mathematic functions and constants from the C99 standard are available
+on many platforms. In the below functions list they are marked [C99].
+
+The mathematical constants include:
+
+ M_SQRT2 # the square root of two
+ M_E # the Euler's (or Napier's) constant
+ M_PI # the Pi
+
+and other related/similar ones
+
+ M_SQRT1_2 # sqrt(1/2)
+ M_LN10 M_LN2 M_LOG10E M_LOG2E
+ M_1_PI M_2_PI M_2_SQRTPI M_PI_2 M_PI_4 # 1/Pi, ..., Pi/4
+
+and the
+
+ INFINITY
+ NAN
+
+The last two are also available as just Inf and NaN.
+
+The Bessel functions (j0, j1, jn, y0, y1, yn) are also available.
+
=head1 CAVEATS
A few functions are not implemented because they are C specific. If you
This is identical to the C function C<acos()>, returning
the arcus cosine of its numerical argument. See also L<Math::Trig>.
+=item C<acosh>
+
+This is identical to the C function C<acos()>, returning the
+hyperbolic arcus cosine of its numerical argument [C99]. See also
+L<Math::Trig>.
+
=item C<alarm>
This is identical to Perl's builtin C<alarm()> function,
This is identical to the C function C<asin()>, returning
the arcus sine of its numerical argument. See also L<Math::Trig>.
+=item C<asinh>
+
+This is identical to the C function C<asin()>, returning the
+hyperbolic arcus sine of its numerical argument [C99]. See also
+L<Math::Trig>.
+
=item C<assert>
Unimplemented, but you can use L<perlfunc/die> and the L<Carp> module
This is identical to the C function C<atan()>, returning the
arcus tangent of its numerical argument. See also L<Math::Trig>.
+=item C<atanh>
+
+This is identical to the C function C<atan()>, returning the
+hyperbolic arcus tangent of its numerical argument [C99]. See also
+L<Math::Trig>.
+
=item C<atan2>
This is identical to Perl's builtin C<atan2()> function, returning
C<calloc()> is C-specific. Perl does memory management transparently.
+=item C<cbrt>
+
+The cube root [C99].
+
=item C<ceil>
This is identical to the C function C<ceil()>, returning the smallest
This is identical to the C function C<cosh()>, for returning
the hyperbolic cosine of its numeric argument. See also L<Math::Trig>.
+=item C<copysign>
+
+Returns the x but with the sign of y [C99].
+
+See also L</signbit>.
+
=item C<creat>
Create a new file. This returns a file descriptor like the ones returned by
Returns C<undef> on failure.
+=item C<erf>
+
+The error function [C99].
+
+=item C<erfc>
+
+The complementary error function [C99].
+
=item C<errno>
Returns the value of errno.
returning the exponent (I<e>-based) of the numerical argument,
see L<perlfunc/exp>.
+=item C<expm1>
+
+Equivalent to C<exp(x) - 1>, but more precise for small argument values [C99].
+
+See also L</log1p>.
+
=item C<fabs>
This is identical to Perl's builtin C<abs()> function for returning
This is identical to the C function C<floor()>, returning the largest
integer value less than or equal to the numerical argument.
+=item C<fdim>
+
+"Positive difference", x - y if x > y, zero otherwise [C99].
+
+=item C<fegetround>
+
+Returns the current floating point rounding mode, one of
+
+ FE_TONEAREST FE_TOWARDZERO FE_UPWARD FE_UPWARD
+
+FE_TONEAREST is like L</round>, FE_TOWARDZERO is like L</trunc> [C99].
+
+=item C<fesetround>
+
+Sets the floating point rounding mode, see L</fegetround>.
+
+=item C<fma>
+
+"Fused multiply-add", x * y + z, possibly faster (and less lossy)
+than the explicit two operations [C99].
+
+=item C<fmax>
+
+Maximum of x and y, except when either is NaN, returns the other [C99].
+
+=item C<fmin>
+
+Minimum of x and y, except when either is NaN, returns the other [C99].
+
=item C<fmod>
This is identical to the C function C<fmod()>.
Returns C<undef> on failure.
+=item C<fpclassify>
+
+Returns one of
+
+ FP_NORMAL FP_ZERO FP_SUBNORMAL FP_INFINITE FP_NAN
+
+telling the class of the argument [C99].
+
=item C<fprintf>
C<fprintf()> is C-specific, see L<perlfunc/printf> instead.
converting seconds since the epoch to a date in Greenwich Mean Time,
see L<perlfunc/gmtime>.
+=item C<hypot>
+
+Equivalent to sqrt(x * x + y * y) except more stable on very large
+or very small arguments [C99].
+
+=item C<ilogb>
+
+Integer binary logarithm [C99]
+
+For example ilogb(20) is 4, as an integer.
+
+See also L</logb>.
+
=item C<isalnum>
Deprecated function whose use raises a warning, and which is slated to
You may want to use the C<L<E<sol>\dE<sol>|perlrecharclass/Digits>>
construct instead.
+=item C<isfinite>
+
+Returns true if the argument is a finite number (that is, not an
+infinity, or the not-a-number) [C99].
+
+See also L</isinf>, L</isnan>, and L</fpclassify>.
+
=item C<isgraph>
Deprecated function whose use raises a warning, and which is slated to
The function returns C<TRUE> if the input string is empty, or if the
corresponding C function returns C<TRUE> for every byte in the string.
+=item C<isgreater>
+
+(Also C<isgreaterequal>, C<isless>, C<islessequal>, C<islessgreater>,
+C<isunordered>)
+
+Floating point comparisons which handle the NaN [C99].
+
+=item C<isinf>
+
+Returns true if the argument is an infinity (positive or negative) [C99].
+
+See also L</isnan>, L</isfinite>, and L</fpclassify>.
+
=item C<islower>
Deprecated function whose use raises a warning, and which is slated to
Do B<not> use C</[a-z]/> unless you don't care about the current locale.
+=item C<isnan>
+
+Returns true if the argument is NaN (not-a-number) [C99].
+
+Note that you cannot test for "NaN-ness" with
+
+ $x == $x
+
+since the NaN is not equivalent to anything, B<including itself>.
+
+See also L</nan>, L</isinf>, and L</fpclassify>.
+
+=item C<isnormal>
+
+Returns true if the argument is normal (that is, not a subnormal/denormal,
+and not an infinity, or a not-a-number) [C99].
+
+See also L</isfinite>, and L</fpclassify>.
+
=item C<isprint>
Deprecated function whose use raises a warning, and which is slated to
The function returns C<TRUE> if the input string is empty, or if the
corresponding C function returns C<TRUE> for every byte in the string.
+=item C<j0>
+
+(Also C<j1>, C<jn>, C<y0>, C<y1>, C<yn>)
+
+The Bessel function of the first kind of the order zero.
+
=item C<kill>
This is identical to Perl's builtin C<kill()> function for sending
(For computing dividends of long integers.)
C<ldiv()> is C-specific, use C</> and C<int()> instead.
+=item C<lgamma>
+
+The logarithm of the Gamma function [C99].
+
+See also L</tgamma>.
+
+=item C<log1p>
+
+Equivalent to log(1 + x), but more stable results for small argument
+values [C99].
+
+=item C<log2>
+
+Logarithm base two [C99].
+
+See also L</expm1>.
+
+=item C<logb>
+
+Integer binary logarithm [C99].
+
+For example logb(20) is 4, as a floating point number.
+
+See also L</ilogb>.
+
=item C<link>
This is identical to Perl's builtin C<link()> function
Returns C<undef> on failure.
+=item C<lrint>
+
+Depending on the current floating point rounding mode, rounds the
+argument either toward nearest (like L</round>), toward zero (like
+L</trunc>), downward (toward negative infinity), or upward (toward
+positive infinity) [C99].
+
+For the rounding mode, see L</fegetround>.
+
+=item C<lround>
+
+Like L</round>, but as integer, as opposed to floating point [C99].
+
+See also L</ceil>, L</floor>, L</trunc>.
+
=item C<malloc>
C<malloc()> is C-specific. Perl does memory management transparently.
=item C<mblen>
This is identical to the C function C<mblen()>.
-Perl does not have any support for the wide and multibyte
-characters of the C standards, so this might be a rather
-useless function.
+
+Core Perl does not have any support for the wide and multibyte
+characters of the C standards, so this might be a rather useless
+function.
+
+However, Perl supports Unicode, see L<perluniintro>.
=item C<mbstowcs>
This is identical to the C function C<mbstowcs()>.
-Perl does not have any support for the wide and multibyte
-characters of the C standards, so this might be a rather
-useless function.
+
+See L</mblen>.
=item C<mbtowc>
This is identical to the C function C<mbtowc()>.
-Perl does not have any support for the wide and multibyte
-characters of the C standards, so this might be a rather
-useless function.
+
+See L</mblen>.
=item C<memchr>
($fractional, $integral) = POSIX::modf( 3.14 );
+See also L</round>.
+
+=item C<nan>
+
+Returns not-a-number [C99].
+
+See also L</isnan>.
+
+=item C<nearbyint>
+
+Returns the nearest integer to the argument, according to the current
+rounding mode (see L</fegetround>) [C99].
+
+=item C<nextafter>
+
+Returns the next representable floating point number after x in the
+direction of y [C99].
+
+Like L</nexttoward>, but potentially less accurate.
+
+=item C<nexttoward>
+
+Returns the next representable floating point number after x in the
+direction of y [C99].
+
+Like L</nextafter>, but potentially more accurate.
+
=item C<nice>
This is similar to the C function C<nice()>, for changing
C<realloc()> is C-specific. Perl does memory management transparently.
+=item C<remainder>
+
+Given x and y, returns the value x - n*y, where n is the integer
+closest to x/y. [C99]
+
+See also L</remquo>.
+
=item C<remove>
This is identical to Perl's builtin C<unlink()> function
for removing files, see L<perlfunc/unlink>.
+=item C<remquo>
+
+Like L</remainder> but also returns the low-order bits of the quotient (n)
+[C99]
+
+(This is quite esoteric interface, mainly used to implement numerical
+algorithms.)
+
=item C<rename>
This is identical to Perl's builtin C<rename()> function
This is identical to Perl's builtin C<rewinddir()> function for
rewinding directory entry streams, see L<perlfunc/rewinddir>.
+=item C<rint>
+
+Identical to L</lrint>.
+
=item C<rmdir>
This is identical to Perl's builtin C<rmdir()> function
for removing (empty) directories, see L<perlfunc/rmdir>.
+=item C<round>
+
+Returns the integer (but still as floating point) nearest to the
+argument [C99].
+
+See also L</ceil>, L</floor>, L</lround>, L</modf>, and L</trunc>.
+
+=item C<scalbn>
+
+Returns x * 2**y [C99].
+
+See also L</frexp> and L</ldexp>.
+
=item C<scanf>
C<scanf()> is C-specific, use E<lt>E<gt> and regular expressions instead,
C<siglongjmp()> is C-specific: use L<perlfunc/die> instead.
+=item C<signbit>
+
+Returns zero for positive arguments, non-zero for negative arguments [C99].
+
=item C<sigpending>
Examine signals that are blocked and pending. This uses C<POSIX::SigSet>
When called in a scalar context strtol returns the parsed number.
+=item C<strtold>
+
+Like L</strtod> but for long doubles. Defined only if the
+system supports long doubles.
+
=item C<strtoul>
String to unsigned (long) integer translation. C<strtoul()> is identical
Returns C<undef> on failure.
+=item C<tgamma>
+
+The Gamma function [C99].
+
+See also L</lgamma>.
+
=item C<time>
This is identical to Perl's builtin C<time()> function
see L<perlfunc/uc>, or the equivalent C<\U> operator inside doublequotish
strings.
+=item C<trunc>
+
+Returns the integer toward zero from the argument [C99].
+
+See also L</ceil>, L</floor>, and L</round>.
+
=item C<ttyname>
This is identical to the C function C<ttyname()> for returning the
=item C<wcstombs>
This is identical to the C function C<wcstombs()>.
-Perl does not have any support for the wide and multibyte
-characters of the C standards, so this might be a rather
-useless function.
+
+See L</mblen>.
=item C<wctomb>
This is identical to the C function C<wctomb()>.
-Perl does not have any support for the wide and multibyte
-characters of the C standards, so this might be a rather
-useless function.
+
+See L</mblen>.
=item C<write>
ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE
ESRCH ESTALE ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY EUSERS
EWOULDBLOCK EXDEV
- EXIT_FAILURE EXIT_SUCCESS FD_CLOEXEC FILENAME_MAX
- FLT_DIG FLT_EPSILON FLT_MANT_DIG FLT_MAX FLT_MAX_10_EXP
- FLT_MAX_EXP FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX
- FLT_ROUNDS F_DUPFD F_GETFD F_GETFL F_GETLK F_OK F_RDLCK
- F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK HUGE_VAL
- HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR INLCR INPCK
- INT_MAX INT_MIN ISIG ISTRIP IXOFF IXON LC_ALL LC_COLLATE
- LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME LDBL_DIG
- LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP
- LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP LINK_MAX
- LONG_MAX LONG_MIN L_ctermid L_cuserid L_tmpname MAX_CANON
- MAX_INPUT MB_CUR_MAX MB_LEN_MAX NAME_MAX NCCS NDEBUG
- NGROUPS_MAX NOFLSH NULL OPEN_MAX OPOST O_ACCMODE O_APPEND
- O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC
- O_WRONLY PARENB PARMRK PARODD PATH_MAX PIPE_BUF RAND_MAX R_OK
- SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND
- SA_RESTART SA_SIGINFO SCHAR_MAX SCHAR_MIN SEEK_CUR SEEK_END
- SEEK_SET SHRT_MAX SHRT_MIN SIGABRT SIGALRM SIGBUS SIGCHLD
- SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGPOLL
- SIGPROF SIGQUIT SIGRTMAX SIGRTMIN SIGSEGV SIGSTOP SIGSYS
- SIGTERM SIGTRAP SIGTSTP SIGTTIN SIGTTOU SIGURG SIGUSR1
- SIGUSR2 SIGVTALRM SIGXCPU SIGXFSZ SIG_BLOCK SIG_DFL SIG_ERR
- SIG_IGN SIG_SETMASK SIG_UNBLOCK SSIZE_MAX STDERR_FILENO
- STDIN_FILENO STDOUT_FILENO STREAM_MAX S_IRGRP S_IROTH S_IRUSR
- S_IRWXG S_IRWXO S_IRWXU S_ISBLK S_ISCHR S_ISDIR S_ISFIFO
- S_ISGID S_ISREG S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP
- S_IXOTH S_IXUSR TCIFLUSH TCIOFF TCIOFLUSH TCION TCOFLUSH
- TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW TMP_MAX TOSTOP
- TZNAME_MAX UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX VEOF VEOL
- VERASE VINTR VKILL VMIN VQUIT VSTART VSTOP VSUSP VTIME
- WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED WNOHANG WSTOPSIG
- WTERMSIG WUNTRACED W_OK X_OK _PC_CHOWN_RESTRICTED
- _PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT _PC_NAME_MAX
- _PC_NO_TRUNC _PC_PATH_MAX _PC_PIPE_BUF _PC_VDISABLE
- _POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_CHOWN_RESTRICTED
- _POSIX_JOB_CONTROL _POSIX_LINK_MAX _POSIX_MAX_CANON
- _POSIX_MAX_INPUT _POSIX_NAME_MAX _POSIX_NGROUPS_MAX
- _POSIX_NO_TRUNC _POSIX_OPEN_MAX _POSIX_PATH_MAX
- _POSIX_PIPE_BUF _POSIX_SAVED_IDS _POSIX_SSIZE_MAX
- _POSIX_STREAM_MAX _POSIX_TZNAME_MAX _POSIX_VDISABLE
- _POSIX_VERSION _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK
- _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE
- _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION _exit
- abort access acos asctime asin assert atan atexit atof atoi
- atol bsearch calloc ceil cfgetispeed cfgetospeed cfsetispeed
- cfsetospeed clearerr clock cosh creat ctermid ctime cuserid
- difftime div dup dup2 errno execl execle execlp execv execve
- execvp fabs fclose fdopen feof ferror fflush fgetc fgetpos
- fgets floor fmod fopen fpathconf fprintf fputc fputs fread
- free freopen frexp fscanf fseek fsetpos fstat fsync ftell
+ EXIT_FAILURE EXIT_SUCCESS FD_CLOEXEC
+ FE_DOWNWARD FE_TONEAREST FE_TOWARDZERO FE_UPWARD
+ FILENAME_MAX FLT_DIG FLT_EPSILON FLT_MANT_DIG FLT_MAX
+ FLT_MAX_10_EXP FLT_MAX_EXP FLT_MIN FLT_MIN_10_EXP
+ FLT_MIN_EXP FLT_RADIX FLT_ROUNDS FP_ILOGB0
+ FP_ILOGBNAN FP_INFINITE FP_NAN FP_NORMAL
+ FP_SUBNORMAL FP_ZERO F_DUPFD F_GETFD F_GETFL F_GETLK
+ F_OK F_RDLCK F_SETFD F_SETFL F_SETLK F_SETLKW
+ F_UNLCK F_WRLCK HUGE_VAL HUPCL ICANON ICRNL IEXTEN
+ IGNBRK IGNCR IGNPAR INFINITY INLCR INPCK INT_MAX
+ INT_MIN ISIG ISTRIP IXOFF IXON Inf LC_ALL LC_COLLATE
+ LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME
+ LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX
+ LDBL_MAX_10_EXP LDBL_MAX_EXP LDBL_MIN
+ LDBL_MIN_10_EXP LDBL_MIN_EXP LINK_MAX LONG_MAX
+ LONG_MIN L_ctermid L_cuserid L_tmpname MAX_CANON
+ MAX_INPUT MB_CUR_MAX MB_LEN_MAX M_1_PI M_2_PI M_2_SQRTPI
+ M_E M_LN10 M_LN2 M_LOG10E M_LOG2E M_PI M_PI_2 M_PI_4
+ M_SQRT1_2 M_SQRT2 NAME_MAX NAN NCCS NDEBUG
+ NGROUPS_MAX NOFLSH NULL NaN OPEN_MAX OPOST O_ACCMODE
+ O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY
+ O_RDWR O_TRUNC O_WRONLY PARENB PARMRK PARODD
+ PATH_MAX PIPE_BUF RAND_MAX R_OK SA_NOCLDSTOP
+ SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND
+ SA_RESTART SA_SIGINFO SCHAR_MAX SCHAR_MIN SEEK_CUR
+ SEEK_END SEEK_SET SHRT_MAX SHRT_MIN SIGABRT SIGALRM
+ SIGBUS SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT
+ SIGKILL SIGPIPE SIGPOLL SIGPROF SIGQUIT SIGRTMAX
+ SIGRTMIN SIGSEGV SIGSTOP SIGSYS SIGTERM SIGTRAP
+ SIGTSTP SIGTTIN SIGTTOU SIGURG SIGUSR1 SIGUSR2
+ SIGVTALRM SIGXCPU SIGXFSZ SIG_BLOCK SIG_DFL SIG_ERR
+ SIG_IGN SIG_SETMASK SIG_UNBLOCK SSIZE_MAX
+ STDERR_FILENO STDIN_FILENO STDOUT_FILENO STREAM_MAX
+ S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
+ S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG
+ S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH
+ S_IXUSR TCIFLUSH TCIOFF TCIOFLUSH TCION TCOFLUSH
+ TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW TMP_MAX
+ TOSTOP TZNAME_MAX UCHAR_MAX UINT_MAX ULONG_MAX
+ USHRT_MAX VEOF VEOL VERASE VINTR VKILL VMIN VQUIT
+ VSTART VSTOP VSUSP VTIME WEXITSTATUS WIFEXITED
+ WIFSIGNALED WIFSTOPPED WNOHANG WSTOPSIG WTERMSIG
+ WUNTRACED W_OK X_OK _PC_CHOWN_RESTRICTED
+ _PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT
+ _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX _PC_PIPE_BUF
+ _PC_VDISABLE _POSIX_ARG_MAX _POSIX_CHILD_MAX
+ _POSIX_CHOWN_RESTRICTED _POSIX_JOB_CONTROL
+ _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT
+ _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_NO_TRUNC
+ _POSIX_OPEN_MAX _POSIX_PATH_MAX _POSIX_PIPE_BUF
+ _POSIX_SAVED_IDS _POSIX_SSIZE_MAX _POSIX_STREAM_MAX
+ _POSIX_TZNAME_MAX _POSIX_VDISABLE _POSIX_VERSION
+ _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK
+ _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX
+ _SC_PAGESIZE _SC_SAVED_IDS _SC_STREAM_MAX
+ _SC_TZNAME_MAX _SC_VERSION _exit abort access acos
+ acosh asctime asin asinh assert atan atanh atexit
+ atof atoi atol bsearch calloc cbrt ceil cfgetispeed
+ cfgetospeed cfsetispeed cfsetospeed clearerr clock
+ copysign cosh creat ctermid ctime cuserid difftime
+ div dup dup2 erf erfc errno execl execle execlp
+ execv execve execvp exp2 expm1 fabs fclose fdim
+ fdopen fegetround feof ferror fesetround fflush
+ fgetc fgetpos fgets floor fma fmax fmin fmod fopen
+ fpathconf fpclassify fprintf fputc fputs fread free
+ freopen frexp fscanf fseek fsetpos fstat fsync ftell
fwrite getchar getcwd getegid getenv geteuid getgid getgroups
- getpid gets getuid isalnum isalpha isatty iscntrl isdigit
- isgraph islower isprint ispunct isspace isupper isxdigit labs
- ldexp ldiv localeconv log10 longjmp lseek malloc mblen
- mbstowcs mbtowc memchr memcmp memcpy memmove memset mkfifo
- mktime modf offsetof pathconf pause perror pow putc putchar
- puts qsort raise realloc remove rewind scanf setbuf setgid
- setjmp setlocale setpgid setsid setuid setvbuf sigaction
- siglongjmp signal sigpending sigprocmask sigsetjmp sigsuspend
- sinh sscanf stderr stdin stdout strcat strchr strcmp strcoll
- strcpy strcspn strerror strftime strlen strncat strncmp
- strncpy strpbrk strrchr strspn strstr strtod strtok strtol
- strtoul strxfrm sysconf tan tanh tcdrain tcflow tcflush
- tcgetattr tcgetpgrp tcsendbreak tcsetattr tcsetpgrp tmpfile
- tmpnam tolower toupper ttyname tzname tzset uname ungetc
- vfprintf vprintf vsprintf wcstombs wctomb)],
- EXPORT_OK => [qw(abs alarm atan2 chdir chmod chown close closedir cos exit
- exp fcntl fileno fork getc getgrgid getgrnam getlogin
- getpgrp getppid getpwnam getpwuid gmtime kill lchown link
- localtime log mkdir nice open opendir pipe printf rand
- read readdir rename rewinddir rmdir sin sleep sprintf sqrt
- srand stat system time times umask unlink utime wait
- waitpid write)],
-);
+ getpid gets getuid hypot ilogb isalnum isalpha
+ isatty iscntrl isdigit isfinite isgraph isgreater
+ isgreaterequal isinf isless islessequal
+ islessgreater islower isnan isnormal isprint ispunct
+ isspace isunordered isupper isxdigit j0 j1 jn labs
+ ldexp ldiv lgamma localeconv log10 log1p log2 logb
+ longjmp lrint lseek malloc mblen mbstowcs mbtowc
+ memchr memcmp memcpy memmove memset mkfifo mktime
+ modf nan nearbyint nextafter nexttoward offsetof
+ pathconf pause perror pow putc putchar puts qsort
+ raise realloc remainder remove remquo rewind rint
+ round scalbn scanf setbuf setgid setjmp setlocale
+ setpgid setsid setuid setvbuf sigaction siglongjmp
+ signal signbit sigpending sigprocmask sigsetjmp
+ sigsuspend sinh sscanf stderr stdin stdout strcat
+ strchr strcmp strcoll strcpy strcspn strerror
+ strftime strlen strncat strncmp strncpy strpbrk
+ strrchr strspn strstr strtod strtok strtol strtold
+ strtoul strxfrm sysconf tan tanh tcdrain tcflow
+ tcflush tcgetattr tcgetpgrp tcsendbreak tcsetattr
+ tcsetpgrp tgamma tmpfile tmpnam tolower toupper
+ trunc ttyname tzname tzset uname ungetc vfprintf
+ vprintf vsprintf wcstombs wctomb y0 y1 yn )],
+ EXPORT_OK => [qw(abs alarm atan2 chdir chmod chown
+ close closedir cos exit exp fcntl fileno fork getc
+ getgrgid getgrnam getlogin getpgrp getppid getpwnam
+ getpwuid gmtime kill lchown link localtime log mkdir
+ nice open opendir pipe printf rand read readdir
+ rename rewinddir rmdir sin sleep sprintf sqrt srand
+ stat system time times umask unlink utime wait
+ waitpid write)], );
plan (tests => 2 * keys %expect);
use POSIX;
use Test::More;
+use Config;
+
# These tests are mainly to make sure that these arithmetic functions
# exist and are accessible. They are not meant to be an exhaustive
# test for the interface.
between(-0.77, tanh(-1), -0.76, 'tanh(-1)');
cmp_ok(tanh(1), '==', -tanh(-1), 'tanh(1) == -tanh(-1)');
+SKIP: {
+ unless ($Config{d_acosh}) {
+ skip "no acosh, suspecting no C99 math", 30;
+ }
+ if ($^O =~ /Win32|VMS/) {
+ skip "running in $^O, C99 math support uneven", 30;
+ }
+ cmp_ok(abs(M_SQRT2 - 1.4142135623731), '<', 1e-9, "M_SQRT2");
+ cmp_ok(abs(M_E - 2.71828182845905), '<', 1e-9, "M_E");
+ cmp_ok(abs(M_PI - 3.14159265358979), '<', 1e-9, "M_PI");
+ cmp_ok(abs(acosh(2) - 1.31695789692482), '<', 1e-9, "acosh");
+ cmp_ok(abs(asinh(1) - 0.881373587019543), '<', 1e-9, "asinh");
+ cmp_ok(abs(atanh(0.5) - 0.549306144334055), '<', 1e-9, "atanh");
+ cmp_ok(abs(cbrt(8) - 2), '<', 1e-9, "cbrt");
+ cmp_ok(abs(cbrt(-27) - -3), '<', 1e-9, "cbrt");
+ cmp_ok(abs(copysign(3.14, -2) - -3.14), '<', 1e-9, "copysign");
+ cmp_ok(abs(expm1(2) - 6.38905609893065), '<', 1e-9, "expm1");
+ cmp_ok(abs(expm1(1e-6) - 1.00000050000017e-06), '<', 1e-9, "expm1");
+ is(fdim(12, 34), 0, "fdim 12 34");
+ is(fdim(34, 12), 22, "fdim 34 12");
+ is(fmax(12, 34), 34, "fmax 12 34");
+ is(fmin(12, 34), 12, "fmin 12 34");
+ SKIP: {
+ unless ($Config{d_fpclassify}) {
+ skip "no fpclassify", 4;
+ }
+ is(fpclassify(1), FP_NORMAL, "fpclassify 1");
+ is(fpclassify(0), FP_ZERO, "fpclassify 0");
+ is(fpclassify(INFINITY), FP_INFINITE, "fpclassify INFINITY");
+ is(fpclassify(NAN), FP_NAN, "fpclassify NAN");
+ }
+ is(hypot(3, 4), 5, "hypot 3 4");
+ cmp_ok(abs(hypot(-2, 1) - sqrt(5)), '<', 1e-9, "hypot -1 2");
+ is(ilogb(255), 7, "ilogb 255");
+ is(ilogb(256), 8, "ilogb 256");
+ SKIP: {
+ unless ($Config{d_isfinite}) {
+ skip "no isfinite", 3;
+ }
+ ok(isfinite(1), "isfinite 1");
+ ok(!isfinite(Inf), "isfinite Inf");
+ ok(!isfinite(NaN), "isfinite NaN");
+ }
+ SKIP: {
+ unless ($Config{d_isinf}) {
+ skip "no isinf", 4;
+ }
+ ok(isinf(INFINITY), "isinf INFINITY");
+ ok(isinf(Inf), "isinf Inf");
+ ok(!isinf(NaN), "isinf NaN");
+ ok(!isinf(42), "isinf 42");
+ }
+ SKIP: {
+ unless ($Config{d_isnan}) {
+ skip "no isnan", 4;
+ }
+ ok(isnan(NAN), "isnan NAN");
+ ok(isnan(NaN), "isnan NaN");
+ ok(!isnan(Inf), "isnan Inf");
+ ok(!isnan(42), "isnan Inf");
+ }
+ cmp_ok(nan(), '!=', nan(), 'nan');
+ cmp_ok(abs(log1p(2) - 1.09861228866811), '<', 1e-9, "log1p");
+ cmp_ok(abs(log1p(1e-6) - 9.99999500000333e-07), '<', 1e-9, "log1p");
+ cmp_ok(abs(log2(8) - 3), '<', 1e-9, "log2");
+ SKIP: {
+ unless ($Config{d_signbit}) {
+ skip "no signbit", 2;
+ }
+ is(signbit(2), 0, "signbit 2"); # zero
+ ok(signbit(-2), "signbit -2"); # non-zero
+ }
+ is(round(2.25), 2, "round 2.25");
+ is(round(-2.25), -2, "round -2.25");
+ is(round(2.5), 3, "round 2.5");
+ is(round(-2.5), -3, "round -2.5");
+ is(round(2.75), 3, "round 2.75");
+ is(round(-2.75), -3, "round 2.75");
+ is(trunc(2.25), 2, "trunc 2.25");
+ is(trunc(-2.25), -2, "trunc -2.25");
+ is(trunc(2.5), 2, "trunc 2.5");
+ is(trunc(-2.5), -2, "trunc -2.5");
+ is(trunc(2.75), 2, "trunc 2.75");
+ is(trunc(-2.75), -2, "trunc -2.75");
+ ok(isless(1, 2), "isless 1 2");
+ ok(!isless(2, 1), "isless 2 1");
+ ok(!isless(1, 1), "isless 1 1");
+ ok(!isless(1, NaN), "isless 1 NaN");
+ ok(isgreater(2, 1), "isgreater 2 1");
+ ok(islessequal(1, 1), "islessequal 1 1");
+ ok(isunordered(1, NaN), "isunordered 1 NaN");
+ cmp_ok(abs(erf(1) - 0.842700792949715), '<', 1.5e-7, "erf 1");
+ cmp_ok(abs(erfc(1) - 0.157299207050285), '<', 1.5e-7, "erfc 1");
+}
+
done_testing();
}
}
-use Test::More tests => 109;
+use Test::More tests => 111;
use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write
errno localeconv dup dup2 lseek access);
}
SKIP: {
+ skip("strtold() not present", 2) unless $Config{d_strtold};
+
+ if ($Config{d_setlocale}) {
+ $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC);
+ &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C');
+ }
+
+ # we're just checking that strtold works, not how accurate it is
+ ($n, $x) = &POSIX::strtod('2.718_ISH');
+ cmp_ok(abs("2.718" - $n), '<', 1e-6, 'strtold works');
+ is($x, 4, 'strtold works');
+
+ &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale};
+}
+
+SKIP: {
skip("strtol() not present", 2) unless $Config{d_strtol};
($n, $x) = &POSIX::strtol('21_PENGUINS');
use warnings;
use Carp;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
require XSLoader;
CODE:
av_store(av, ix, SvREFCNT_inc(sv));
+SV *
+cv_name(SVREF ref, ...)
+ CODE:
+ RETVAL = SvREFCNT_inc(cv_name((CV *)ref, items>1 ? ST(1) : NULL));
+ OUTPUT:
+ RETVAL
+
MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
int
skip_all("clone_with_stack requires threads");
}
-plan(4);
+plan(5);
fresh_perl_is( <<'----', <<'====', undef, "minimal clone_with_stack" );
use XS::APItest;
====
}
+
+{
+ fresh_perl_is( <<'----', <<'====', undef, "with a lexical sub" );
+use XS::APItest;
+use experimental lexical_subs=>;
+my sub f { print "42\n" }
+clone_with_stack();
+f();
+----
+42
+====
+
+}
--- /dev/null
+use XS::APItest;
+use Test::More tests => 15;
+use feature "lexical_subs", "state";
+no warnings "experimental::lexical_subs";
+
+is (cv_name(\&foo), 'main::foo', 'cv_name with package sub');
+is (cv_name(*{"foo"}{CODE}), 'main::foo',
+ 'cv_name with package sub via glob');
+is (cv_name(\*{"foo"}), 'main::foo', 'cv_name with typeglob');
+is (cv_name(\"foo"), 'foo', 'cv_name with string');
+state sub lex1;
+is (cv_name(\&lex1), 'lex1', 'cv_name with lexical sub');
+
+$ret = \cv_name(\&bar, $name);
+is $ret, \$name, 'cv_name with package sub returns 2nd argument';
+is ($name, 'main::bar', 'retval of cv_name with package sub & 2nd arg');
+$ret = \cv_name(*{"bar"}{CODE}, $name);
+is $ret, \$name, 'cv_name with package sub via glob returns 2nd argument';
+is ($name, 'main::bar', 'retval of cv_name w/pkg sub via glob & 2nd arg');
+$ret = \cv_name(\*{"bar"}, $name);
+is $ret, \$name, 'cv_name with typeglob returns 2nd argument';
+is ($name, 'main::bar', 'retval of cv_name with typeglob & 2nd arg');
+$ret = \cv_name(\"bar", $name);
+is $ret, \$name, 'cv_name with string returns 2nd argument';
+is ($name, 'bar', 'retval of cv_name with string & 2nd arg');
+state sub lex2;
+$ret = \cv_name(\&lex2, $name);
+is $ret, \$name, 'cv_name with lexical sub returns 2nd argument';
+is ($name, 'lex2', 'retval of cv_name with lexical sub & 2nd arg');
#[ "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],
+ # even without PERL_SCAN_TRAILING nan can have weird stuff trailing
+ [ "nanx", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ],
+ [ "nanx", PERL_SCAN_TRAILING, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ],
);
for my $grok (@groks) {
}
use XS::APItest;
+use Config;
BEGIN {
eval { require POSIX; POSIX->import("locale_h") };
plan tests => 2;
-is(test_Gconvert(4.179, 2), "4.2", "Gconvert doesn't recognize underlying locale outside 'use locale'");
-use locale;
-is(test_Gconvert(4.179, 2), "4.2", "Gconvert doesn't recognize underlying locale inside 'use locale'");
+SKIP: {
+ if ($Config{usequadmath}) {
+ skip "no gconvert with usequadmath", 2;
+ }
+ is(test_Gconvert(4.179, 2), "4.2", "Gconvert doesn't recognize underlying locale outside 'use locale'");
+ use locale;
+ is(test_Gconvert(4.179, 2), "4.2", "Gconvert doesn't recognize underlying locale inside 'use locale'");
+}
+BEGIN {
+ require Config; import Config;
+ if ($Config{usequadmath}) {
+ print "1..0 # Skip: usequadmath\n";
+ exit(0);
+ }
+}
+
use Test::More tests => 11;
BEGIN { use_ok('XS::APItest') };
package attributes;
-our $VERSION = 0.22;
+our $VERSION = 0.23;
@EXPORT_OK = qw(get reftype);
@EXPORT = ();
}
break;
default:
- if (memEQs(name, 6, "shared")) {
+ if (memEQs(name, len, "shared")) {
if (negated)
Perl_croak(aTHX_ "A variable may not be unshared");
SvSHARE(sv);
chomp(my @strs= grep { !/^\s*\#/ } <DATA>);
my $out = runperl(progfile => "t/regop.pl", stderr => 1 );
# VMS currently embeds linefeeds in the output.
-$out =~ s/\cJ//g if $^O == 'VMS';
+$out =~ s/\cJ//g if $^O eq 'VMS';
my @tests = grep { /\S/ } split /(?=Compiling REx)/, $out;
# on debug builds we get an EXECUTING... message in there at the top
shift @tests
Freeing REx: "[q]"
---
#Compiling REx "^(\S{1,9}):\s*(\d+)$"
-#synthetic stclass "ANYOF[\x{00}-\x{08}\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY]".
+#synthetic stclass "ANYOF[\x{00}-\x{06}\a\b\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY]".
#Final program:
-# 1: BOL (2)
+# 1: SBOL (2)
# 2: OPEN1 (4)
# 4: CURLY {1,9} (7)
# 6: NPOSIXD[\s] (0)
# 17: CLOSE2 (19)
# 19: EOL (20)
# 20: END (0)
-#floating ":" at 1..9 (checking floating) stclass ANYOF[\x{00}-\x{08}\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY] anchored(BOL) minlen 3
+#floating ":" at 1..9 (checking floating) stclass ANYOF[\x{00}-\x{06}\a\b\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY] anchored(SBOL) minlen 3
#Freeing REx: "^(\S{1,9}):\s*(\d+)$"
-floating ":" at 1..9 (checking floating) stclass ANYOF[\x{00}-\x{08}\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY] anchored(BOL) minlen 3
+floating ":" at 1..9 (checking floating) stclass ANYOF[\x{00}-\x{06}\a\b\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY] anchored(SBOL) minlen 3
%MATCHED%
synthetic stclass
no_wrongref
op_desc
op_name
+op_private_bitdef_ix
+op_private_bitdefs
+op_private_bitfields
+op_private_labels
+op_private_valid
opargs
phase_names
ppaddr
void
Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
{
- GV * const oldgv = CvGV(cv);
+ GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv;
HEK *hek;
PERL_ARGS_ASSERT_CVGV_SET;
sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
}
}
- else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek);
+ else if ((hek = CvNAME_HEK(cv))) {
+ unshare_hek(hek);
+ CvNAMED_off(cv);
+ CvLEXICAL_off(cv);
+ }
SvANY(cv)->xcv_gv_u.xcv_gv = gv;
assert(!CvCVGV_RC(cv));
}
}
+/* Convert CvSTASH + CvNAME_HEK into a GV. Conceptually, all subs have a
+ GV, but for efficiency that GV may not in fact exist. This function,
+ called by CvGV, reifies it. */
+
+GV *
+Perl_cvgv_from_hek(pTHX_ CV *cv)
+{
+ GV *gv;
+ SV **svp;
+ PERL_ARGS_ASSERT_CVGV_FROM_HEK;
+ assert(SvTYPE(cv) == SVt_PVCV);
+ if (!CvSTASH(cv)) return NULL;
+ ASSUME(CvNAME_HEK(cv));
+ svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0);
+ gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0));
+ if (!isGV(gv))
+ gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)),
+ HEK_LEN(CvNAME_HEK(cv)),
+ SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv)));
+ if (!CvNAMED(cv)) { /* gv_init took care of it */
+ assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv);
+ return gv;
+ }
+ unshare_hek(CvNAME_HEK(cv));
+ CvNAMED_off(cv);
+ SvANY(cv)->xcv_gv_u.xcv_gv = gv;
+ if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv);
+ CvCVGV_RC_on(cv);
+ return gv;
+}
+
/* Assign CvSTASH(cv) = st, handling weak references. */
void
assert (!(proto && has_constant));
if (has_constant) {
- /* The constant has to be a simple scalar type. */
+ /* The constant has to be a scalar, array or subroutine. */
switch (SvTYPE(has_constant)) {
case SVt_PVHV:
- case SVt_PVCV:
case SVt_PVFM:
case SVt_PVIO:
Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ));
if (flags & GV_ADDMULTI || doproto) /* doproto means it */
GvMULTI_on(gv); /* _was_ mentioned */
- if (doproto) {
+ if (has_constant && SvTYPE(has_constant) == SVt_PVCV) {
+ /* Not actually a constant. Just a regular sub. */
+ CV * const cv = (CV *)has_constant;
+ GvCV_set(gv,cv);
+ if (CvSTASH(cv) == stash && (
+ CvNAME_HEK(cv) == GvNAME_HEK(gv)
+ || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv))
+ && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv))
+ && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv))
+ && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv))
+ )
+ ))
+ CvGV_set(cv,gv);
+ }
+ else if (doproto) {
CV *cv;
if (has_constant) {
/* newCONSTSUB takes ownership of the reference from us. */
GV* stubgv;
GV* autogv;
- if (CvANON(cv) || !CvGV(cv))
+ if (CvANON(cv) || CvLEXICAL(cv))
stubgv = gv;
else {
stubgv = CvGV(cv);
* use that, but for lack of anything better we will use the sub's
* original package to look up $AUTOLOAD.
*/
- varstash = GvSTASH(CvGV(cv));
+ varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
ENTER;
The most important of which are probably GV_ADD and SVf_UTF8.
+Note, use of C<gv_stashsv> instead of C<gv_stashpvn> where possible is strongly
+recommended for performance reasons.
+
=cut
*/
-HV*
-Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
+/*
+gv_stashpvn_internal
+
+Perform the internal bits of gv_stashsvpvn_cached. You could think of this
+as being one half of the logic. Not to be called except from gv_stashsvpvn_cached().
+
+*/
+
+PERL_STATIC_INLINE HV*
+S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags)
{
char smallbuf[128];
char *tmpbuf;
GV *tmpgv;
U32 tmplen = namelen + 2;
- PERL_ARGS_ASSERT_GV_STASHPVN;
+ PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL;
if (tmplen <= sizeof smallbuf)
tmpbuf = smallbuf;
}
/*
+gv_stashsvpvn_cached
+
+Returns a pointer to the stash for a specified package, possibly
+cached. Implements both C<gv_stashpvn> and C<gc_stashsv>.
+
+Requires one of either namesv or namepv to be non-null.
+
+See C<gv_stashpvn> for details on "flags".
+
+Note the sv interface is strongly preferred for performance reasons.
+
+*/
+
+#define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \
+ assert(namesv || name)
+
+PERL_STATIC_INLINE HV*
+S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags)
+{
+ HV* stash;
+ HE* he;
+
+ PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED;
+
+ he = (HE *)hv_common(
+ PL_stashcache, namesv, name, namelen,
+ (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
+ );
+
+ if (he) return INT2PTR(HV*,SvIVX(HeVAL(he)));
+ else if (flags & GV_CACHE_ONLY) return NULL;
+
+ if (namesv) {
+ if (SvOK(namesv)) { /* prevent double uninit warning */
+ STRLEN len;
+ name = SvPV_const(namesv, len);
+ namelen = len;
+ flags |= SvUTF8(namesv);
+ } else {
+ name = ""; namelen = 0;
+ }
+ }
+ stash = gv_stashpvn_internal(name, namelen, flags);
+
+ if (stash && namelen) {
+ SV* const ref = newSViv(PTR2IV(stash));
+ (void)hv_store(PL_stashcache, name,
+ (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
+ }
+
+ return stash;
+}
+
+HV*
+Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
+{
+ PERL_ARGS_ASSERT_GV_STASHPVN;
+ return gv_stashsvpvn_cached(NULL, name, namelen, flags);
+}
+
+/*
=for apidoc gv_stashsv
Returns a pointer to the stash for a specified package. See C<gv_stashpvn>.
+Note this interface is strongly preferred over C<gv_stashpvn> for performance reasons.
+
=cut
*/
HV*
Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
{
- STRLEN len;
- const char * const ptr = SvPV_const(sv,len);
-
PERL_ARGS_ASSERT_GV_STASHSV;
-
- return gv_stashpvn(ptr, len, flags | SvUTF8(sv));
+ return gv_stashsvpvn_cached(sv, NULL, 0, flags);
}
if (!*stash) {
if (add && !PL_in_clean_all) {
- SV * const err = Perl_mess(aTHX_
+ GV *gv;
+ qerror(Perl_mess(aTHX_
"Global symbol \"%s%"UTF8f
- "\" requires explicit package name",
+ "\" requires explicit package name (did you forget to "
+ "declare \"my %s%"UTF8f"\"?)",
(sv_type == SVt_PV ? "$"
: sv_type == SVt_PVAV ? "@"
: sv_type == SVt_PVHV ? "%"
- : ""), UTF8fARG(is_utf8, len, name));
- GV *gv;
- if (is_utf8)
- SvUTF8_on(err);
- qerror(err);
+ : ""), UTF8fARG(is_utf8, len, name),
+ (sv_type == SVt_PV ? "$"
+ : sv_type == SVt_PVAV ? "@"
+ : sv_type == SVt_PVHV ? "%"
+ : ""), UTF8fARG(is_utf8, len, name)));
/* To maintain the output of errors after the strict exception
* above, and to keep compat with older releases, rather than
* placing the variables in the pad, we place
numifying instead of C's "+0". */
gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
cv = 0;
- if (gv && (cv = GvCV(gv))) {
- if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
- const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
- if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
- && strEQ(hvname, "overload")) {
+ if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) {
+ const HEK * const gvhek =
+ CvNAMED(cv) ? CvNAME_HEK(cv) : GvNAME_HEK(CvGV(cv));
+ const HEK * const stashek =
+ HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)));
+ if (HEK_LEN(gvhek) == 3 && strEQ(HEK_KEY(gvhek), "nil")
+ && stashek && HEK_LEN(stashek) == 8
+ && strEQ(HEK_KEY(stashek), "overload")) {
/* This is a hack to support autoloading..., while
knowing *which* methods were declared as overloaded. */
/* GvSV contains the name of the method. */
}
}
cv = GvCV(gv = ngv);
- }
}
DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
(void)hv_deletehek(stash, gvnhek, G_DISCARD);
} else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 &&
!SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
- CvSTASH(cv) == stash && CvGV(cv) == gv &&
+ CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv &&
CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
!CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
(namehek = GvNAME_HEK(gv)) &&
SV * gp_sv; /* scalar value */
struct io * gp_io; /* filehandle value */
CV * gp_cv; /* subroutine value */
- U32 gp_cvgen; /* generational validity of cached gv_cv */
+ U32 gp_cvgen; /* generational validity of cached gp_cv */
U32 gp_refcnt; /* how many globs point to this? */
HV * gp_hv; /* hash value */
AV * gp_av; /* array value */
CV * gp_form; /* format value */
GV * gp_egv; /* effective gv, if *glob */
line_t gp_line; /* line first declared at (for -w) */
+ U32 gp_flags;
HEK * gp_file_hek; /* file first declared in (for -w) */
};
#define GvCVGEN(gv) (GvGP(gv)->gp_cvgen)
#define GvCVu(gv) (GvGP(gv)->gp_cvgen ? NULL : GvGP(gv)->gp_cv)
+#define GvGPFLAGS(gv) (GvGP(gv)->gp_flags)
+
#define GvLINE(gv) (GvGP(gv)->gp_line)
#define GvFILE_HEK(gv) (GvGP(gv)->gp_file_hek)
#define GvFILEx(gv) HEK_KEY(GvFILE_HEK(gv))
#define GVf_INTRO 0x01
#define GVf_MULTI 0x02
#define GVf_ASSUMECV 0x04
-#define GVf_IN_PAD 0x08
+/* UNUSED 0x08 */
#define GVf_IMPORTED 0xF0
#define GVf_IMPORTED_SV 0x10
#define GVf_IMPORTED_AV 0x20
#define GvIMPORTED_CV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_CV)
#define GvIMPORTED_CV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_CV)
-#define GvIN_PAD(gv) (GvFLAGS(gv) & GVf_IN_PAD)
-#define GvIN_PAD_on(gv) (GvFLAGS(gv) |= GVf_IN_PAD)
-#define GvIN_PAD_off(gv) (GvFLAGS(gv) &= ~GVf_IN_PAD)
+#define GPf_ALIASED_SV 1
+
+#define GvALIASED_SV(gv) (GvGPFLAGS(gv) & GPf_ALIASED_SV)
+#define GvALIASED_SV_on(gv) (GvGPFLAGS(gv) |= GPf_ALIASED_SV)
+#define GvALIASED_SV_off(gv) (GvGPFLAGS(gv) &= ~GPf_ALIASED_SV)
#ifndef PERL_CORE
+# define GvIN_PAD(gv) 0
+# define GvIN_PAD_on(gv) NOOP
+# define GvIN_PAD_off(gv) NOOP
# define Nullgv Null(GV*)
#endif
#define GV_ADDMULTI 0x02 /* add, pretending it has been added
already; used also by gv_init_* */
#define GV_ADDWARN 0x04 /* add, but warn if symbol wasn't already there */
-#define GV_ADDINEVAL 0x08 /* add, as though we're doing so within an eval */
+ /* 0x08 UNUSED */
#define GV_NOINIT 0x10 /* add, but don't init symbol, if type != PVGV */
/* This is used by toke.c to avoid turing placeholder constants in the symbol
table into full PVGVs with attached constant subroutines. */
#define GV_ADDMG 0x400 /* add if magical */
#define GV_NO_SVGMAGIC 0x800 /* Skip get-magic on an SV argument;
used only by gv_fetchsv(_nomg) */
+#define GV_CACHE_ONLY 0x1000 /* return stash only if found in cache;
+ used only in flags parameter to gv_stash* family */
/* Flags for gv_fetchmeth_pvn and gv_autoload_pvn*/
#define GV_SUPER 0x1000 /* SUPER::method */
# define _CC_QUOTEMETA 21
# define _CC_NON_FINAL_FOLD 22
# define _CC_IS_IN_SOME_FOLD 23
-/* Unused: 24-31
+# define _CC_MNEMONIC_CNTRL 24
+/* Unused: 25-31
* If more bits are needed, one could add a second word for non-64bit
* QUAD_IS_INT systems, using some #ifdefs to distinguish between having a 2nd
* word or not. The IS_IN_SOME_FOLD bit is the most easily expendable, as it
# define isALPHANUMERIC_A(c) _generic_isCC_A(c, _CC_ALPHANUMERIC)
# define isBLANK_A(c) _generic_isCC_A(c, _CC_BLANK)
# define isCNTRL_A(c) _generic_isCC_A(c, _CC_CNTRL)
-# define isDIGIT_A(c) _generic_isCC(c, _CC_DIGIT)
+# define isDIGIT_A(c) _generic_isCC(c, _CC_DIGIT) /* No non-ASCII digits */
# define isGRAPH_A(c) _generic_isCC_A(c, _CC_GRAPH)
# define isLOWER_A(c) _generic_isCC_A(c, _CC_LOWER)
# define isPRINT_A(c) _generic_isCC_A(c, _CC_PRINT)
# define isSPACE_A(c) _generic_isCC_A(c, _CC_SPACE)
# define isUPPER_A(c) _generic_isCC_A(c, _CC_UPPER)
# define isWORDCHAR_A(c) _generic_isCC_A(c, _CC_WORDCHAR)
-# define isXDIGIT_A(c) _generic_isCC(c, _CC_XDIGIT)
+# define isXDIGIT_A(c) _generic_isCC(c, _CC_XDIGIT) /* No non-ASCII xdigits */
# define isIDFIRST_A(c) _generic_isCC_A(c, _CC_IDFIRST)
# define isALPHA_L1(c) _generic_isCC(c, _CC_ALPHA)
# define isALPHANUMERIC_L1(c) _generic_isCC(c, _CC_ALPHANUMERIC)
_generic_isCC(c, _CC_NON_FINAL_FOLD)
# define _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c) \
_generic_isCC(c, _CC_IS_IN_SOME_FOLD)
+# define _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c) \
+ _generic_isCC(c, _CC_MNEMONIC_CNTRL)
#else /* else we don't have perl.h */
/* If we don't have perl.h, we are compiling a utility program. Below we
* both ASCII and EBCDIC the last 3 bits of the octal digits range from 0-7. */
#define OCTAL_VALUE(c) (__ASSERT_(isOCTAL(c)) (7 & (c)))
+/* Efficiently returns a boolean as to if two native characters are equivalent
+ * case-insenstively. At least one of the characters must be one of [A-Za-z];
+ * the ALPHA in the name is to remind you of that. This is asserted() in
+ * DEBUGGING builds. Because [A-Za-z] are invariant under UTF-8, this macro
+ * works (on valid input) for both non- and UTF-8-encoded bytes.
+ *
+ * When one of the inputs is a compile-time constant and gets folded by the
+ * compiler, this reduces to an AND and a TEST. On both EBCDIC and ASCII
+ * machines, 'A' and 'a' differ by a single bit; the same with the upper and
+ * lower case of all other ASCII-range alphabetics. On ASCII platforms, they
+ * are 32 apart; on EBCDIC, they are 64. At compile time, this uses an
+ * exclusive 'or' to find that bit and then inverts it to form a mask, with
+ * just a single 0, in the bit position where the upper- and lowercase differ.
+ * */
+#define isALPHA_FOLD_EQ(c1, c2) \
+ (__ASSERT_(isALPHA_A(c1) || isALPHA_A(c2)) \
+ ((c1) & ~('A' ^ 'a')) == ((c2) & ~('A' ^ 'a')))
+#define isALPHA_FOLD_NE(c1, c2) (! isALPHA_FOLD_EQ((c1), (c2)))
+
/*
=head1 Memory Management
d_setruid='undef'
alignbytes=8
-
case "$usemymalloc" in
'') usemymalloc='n' ;;
esac
i_gdbm='undef'
i_gdbmndbm='undef'
fi
+
+# Some releases (and patch levels) of AIX cannot have both
+# long doubles and infinity (infinity plus one equals ... NaNQ!)
+#
+# This deficiency, and others, is apparently a well-documented feature
+# of AIX 128-bit long doubles:
+#
+# http://www-01.ibm.com/support/knowledgecenter/ssw_aix_61/com.ibm.aix.genprogc/128bit_long_double_floating-point_datatype.htm
+#
+# The URL seems to be fragile, it has moved around over the years,
+# but searching AIX docs at ibm.com for "128-bit long double
+# floating-point data type" should surface the latest info.
+#
+# Some salient points:
+#
+# <quote>
+# * The 128-bit implementation differs from the IEEE standard for long double
+# in the following ways:
+# * Supports only round-to-nearest mode. If the application changes
+# the rounding mode, results are undefined.
+# * Does not fully support the IEEE special numbers NaN and INF.
+# * Does not support IEEE status flags for overflow, underflow,
+# and other conditions. These flags have no meaning for the 128-bit
+# long double inplementation.
+# * The 128-bit long double data type does not support the following math
+# APIs: atanhl, cbrtl, copysignl, exp2l, expm1l, fdiml, fmal, fmaxl,
+# fminl, hypotl, ilogbl, llrintl, llroundl, log1pl, log2l, logbl,
+# lrintl, lroundl, nanl, nearbyintl, nextafterl, nexttoward,
+# nexttowardf, nexttowardl, remainderl, remquol, rintl, roundl,
+# scalblnl, scalbnl, tgammal, and truncl.
+# * The representation of 128-bit long double numbers means that the
+# following macros required by standard C in the values.h file do not
+# have clear meaning:
+# * Number of bits in the mantissa (LDBL_MANT_DIG)
+# * Epsilon (LBDL_EPSILON)
+# * Maximum representable finite value (LDBL_MAX)
+# </quote>
+#
+# The missing math functions affect the POSIX extension math interfaces.
+
+case "$uselongdouble" in
+define)
+ echo "Checking if your infinity is working with long doubles..." >&4
+ cat > inf$$.c <<EOF
+#include <math.h>
+#include <stdio.h>
+int main() {
+ long double inf = INFINITY;
+ long double one = 1.0L;
+ printf("%Lg\n", inf + one);
+}
+EOF
+ $cc -qlongdouble -o inf$$ inf$$.c -lm
+ case `./inf$$` in
+ INF) echo "Your infinity is working correctly with long doubles." >&4 ;;
+ *) # NaNQ
+ echo " "
+ echo "Your infinity is broken, I suggest disabling long doubles." >&4
+ rp="Disable long doubles?"
+ dflt="y"
+ . UU/myread
+ case "$ans" in
+ [Yy]*)
+ echo "Okay, disabling long doubles." >&4
+ uselongdouble=undef
+ ccflags=`echo " $ccflags " | sed -e 's/ -qlongdouble / /'`
+ libswanted=`echo " $libswanted " | sed -e 's/ c128/ /'`
+ lddlflags=`echo " $lddlflags " | sed -e 's/ -lc128 / /'`
+ ;;
+ *)
+ echo "Okay, keeping long doubles enabled." >&4
+ ;;
+ esac
+ ;;
+ esac
+ rm -f inf$$.c inf$$
+ ;;
+esac
+
+# Some releases (and patch levels) of AIX have a broken powl().
+pp_cflags=''
+case "$uselongdouble" in
+define)
+ echo "Checking if your powl() is broken..." >&4
+ cat > powl$$.c <<EOF
+#include <math.h>
+#include <stdio.h>
+int main() {
+ printf("%Lg\n", powl(-3.0L, 2.0L));
+}
+EOF
+ $cc -qlongdouble -o powl$$ powl$$.c -lm
+ case `./powl$$` in
+ 9) echo "Your powl() is working correctly." >&4 ;;
+ *)
+ echo "Your powl() is broken, will use a workaround." >&4
+ pp_cflags='ccflags="$ccflags -DHAS_AIX_POWL_NEG_BASE_BUG"'
+ ;;
+ esac
+ rm -f powl$$.c powl$$
+ ;;
+esac
+
# EOF
# 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.3
+# mkdir -p /opt/perl-catamount/lib/perl5/5.21.4
# mkdir -p /opt/perl-catamount/bin
# cp *.h /opt/perl-catamount/include
# cp libperl.a /opt/perl-catamount/lib
-# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.21.3
+# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.21.4
# cp miniperl perl run.sh cc.sh /opt/perl-catamount/lib
#
# With the headers and the libperl.a you can embed Perl to your Catamount
;;
esac
+# finite() deprecated in 10.9, use isfinite() instead.
+case "$osvers" in
+[1-8].*) ;;
+*) d_finite='undef' ;;
+esac
+
# This was previously used in all but causes three cases
# (no -Ddprefix=, -Dprefix=/usr, -Dprefix=/some/thing/else)
# but that caused too much grief.
# Allow the user to override ld, but modify it as necessary below
case "$ld" in
- '') ld='cc';;
+ '') case "$cc" in
+ # If the cc is explicitly something else than cc (or empty),
+ # set the ld to be that explicitly something else. Conversely,
+ # if the cc is 'cc' (or empty), set the ld to be 'cc'.
+ cc|'') ld='cc';;
+ *) ld="$cc" ;;
+ esac
+ ;;
esac
# Perl bundles do not expect two-level namespace, added in Darwin 1.4.
# NeilW says this should be acceptable on all darwin versions.
ranlib='ranlib'
+# Catch MacPorts gcc/g++ extra libdir
+case "$($cc -v 2>&1)" in
+*"MacPorts gcc"*) loclibpth="$loclibpth /opt/local/lib/libgcc" ;;
+esac
+
##
# Build process
##
# H.Merijn says it's not 1998 anymore: ODBM is not needed,
# and it seems to be buggy in HP-UX anyway.
i_dbm=undef
+
+# In HP-UXes prior to 11.23 strtold() returned a HP-UX
+# specific union called long_double, not a C99 long double.
+case "`grep 'double strtold.const' /usr/include/stdlib.h`" in
+*"long double strtold"*) ;; # strtold should be safe.
+*) echo "Looks like your strtold() is non-standard..." >&4
+ d_strtold=undef ;;
+esac
+
+# In pre-11 HP-UXes there really isn't isfinite(), despite what
+# Configure might think. (There is finite(), though.)
+case "`grep 'isfinite' /usr/include/math.h`" in
+*"isfinite"*) ;;
+*) d_isfinite=undef ;;
+esac
case "$usecrosscompile" in
define)
+# The tests for this in Configure doesn't play nicely with
+# cross-compiling
+d_procselfexe="define"
if $test "X$hostosname" = "Xdarwin"; then
firstmakefile=GNUmakefile;
fi
;;
esac
-$cat <<EOO >> $pwd/config.arch
+$cat <<'EOO' >> $pwd/config.arch
osname='android'
+eval "libpth='$libpth /system/lib /vendor/lib'"
+
+if $test "X$procselfexe" = X; then
+ case "$d_procselfexe" in
+ define) procselfexe='"/proc/self/exe"';;
+ esac
+fi
EOO
# Android is a linux variant, so run those hints.
/* ------------------------------- cv.h ------------------------------- */
+PERL_STATIC_INLINE GV *
+S_CvGV(pTHX_ CV *sv)
+{
+ return CvNAMED(sv)
+ ? Perl_cvgv_from_hek(aTHX_ sv)
+ : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
+}
+
PERL_STATIC_INLINE I32 *
S_CvDEPTHp(const CV * const sv)
{
PERLVAR(I, markstack_ptr, I32 *)
PERLVAR(I, markstack_max, I32 *)
+PERLVARI(I, sawalias, bool, FALSE) /* must enable common-vars
+ pessimisation */
+
#ifdef PERL_HASH_RANDOMIZE_KEYS
#ifdef USE_PERL_PERTURB_KEYS
PERLVARI(I, hash_rand_bits_enabled, U8, 1) /* used to randomize hash stuff 0 == no-random, 1 == random, 2 == determinsitic */
PERLVARI(I, statname, SV *, NULL)
#ifdef HAS_TIMES
-/* Will be removed soon after v5.21.3. See RT #121351 */
+/* Will be removed soon after v5.21.4. See RT #121351 */
PERLVAR(I, timesbuf, struct tms)
#endif
PERLVAR(I, min_intro_pending, I32) /* start of vars to introduce */
PERLVAR(I, max_intro_pending, I32) /* end of vars to introduce */
-PERLVAR(I, padix, I32) /* max used index in current "register" pad */
+PERLVAR(I, padix, I32) /* lowest unused index - 1
+ in current "register" pad */
+PERLVAR(I, constpadix, I32) /* lowest unused for constants */
PERLVAR(I, padix_floor, I32) /* how low may inner block reset padix */
PERLVAR(I, Latin1, SV *)
PERLVAR(I, UpperLatin1, SV *) /* Code points 128 - 255 */
PERLVAR(I, AboveLatin1, SV *)
+PERLVAR(I, InBitmap, SV *)
PERLVAR(I, NonL1NonFinalFold, SV *)
PERLVAR(I, HasMultiCharFold, SV *)
/* Hook for File::Glob */
PERLVARI(I, globhook, globhook_t, NULL)
-/* The last unconditional member of the interpreter structure when 5.21.3 was
+/* The last unconditional member of the interpreter structure when 5.21.4 was
released. The offset of the end of this is baked into a global variable in
any shared perl library which will allow a sanity test in future perl
releases. */
/* U+04 EOT */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+05 ENQ */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+06 ACK */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE),
-/* U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
+/* U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL),
+/* U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL),
+/* U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_MNEMONIC_CNTRL),
+/* U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL),
/* U+0B VT */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
-/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
-/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
+/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL),
+/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL),
/* U+0E SO */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+0F SI */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+10 DLE */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+18 CAN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+19 EOM */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+1A SUB */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL),
/* U+1C FS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+1D GS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+1E RS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+02 STX */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+03 ETX */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x04 U+9C ST */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* 0x05 U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE),
+/* 0x05 U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_MNEMONIC_CNTRL),
/* 0x06 U+86 SSA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x07 U+7F DEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x08 U+97 EPA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x09 U+8D RI */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x0A U+8E SS2 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+0B VT */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
-/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
-/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
+/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL),
+/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL),
/* U+0E SO */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+0F SI */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+10 DLE */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+12 DC2 */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+13 DC3 */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x14 U+9D OSC */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* 0x15 U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
-/* 0x16 U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* 0x15 U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL),
+/* 0x16 U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL),
/* 0x17 U+87 ESA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+18 CAN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+19 EOM */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x24 U+84 IND */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x25 U+85 NEL */ (1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
/* 0x26 U+17 ETB */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* 0x27 U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* 0x27 U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL),
/* 0x28 U+88 HTS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x29 U+89 HTJ */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x2A U+8A VTS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x2C U+8C PLU */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x2D U+05 ENQ */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x2E U+06 ACK */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* 0x2F U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* 0x2F U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL),
/* 0x30 U+90 DCS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x31 U+91 PU1 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x32 U+16 SYN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+02 STX */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+03 ETX */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x04 U+9C ST */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* 0x05 U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE),
+/* 0x05 U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_MNEMONIC_CNTRL),
/* 0x06 U+86 SSA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x07 U+7F DEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x08 U+97 EPA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x09 U+8D RI */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x0A U+8E SS2 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+0B VT */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
-/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
-/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
+/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL),
+/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL),
/* U+0E SO */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+0F SI */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+10 DLE */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+13 DC3 */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x14 U+9D OSC */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x15 U+85 NEL */ (1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
-/* 0x16 U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* 0x16 U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL),
/* 0x17 U+87 ESA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+18 CAN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+19 EOM */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x22 U+82 BPH */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x23 U+83 NBH */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x24 U+84 IND */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* 0x25 U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
+/* 0x25 U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL),
/* 0x26 U+17 ETB */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* 0x27 U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* 0x27 U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL),
/* 0x28 U+88 HTS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x29 U+89 HTJ */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x2A U+8A VTS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x2C U+8C PLU */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x2D U+05 ENQ */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x2E U+06 ACK */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* 0x2F U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* 0x2F U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL),
/* 0x30 U+90 DCS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x31 U+91 PU1 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x32 U+16 SYN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+02 STX */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+03 ETX */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x04 U+9C ST */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* 0x05 U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE),
+/* 0x05 U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_MNEMONIC_CNTRL),
/* 0x06 U+86 SSA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x07 U+7F DEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x08 U+97 EPA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x09 U+8D RI */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x0A U+8E SS2 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+0B VT */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
-/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
-/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
+/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL),
+/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL),
/* U+0E SO */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+0F SI */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+10 DLE */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+12 DC2 */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+13 DC3 */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x14 U+9D OSC */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* 0x15 U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
-/* 0x16 U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* 0x15 U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL),
+/* 0x16 U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL),
/* 0x17 U+87 ESA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+18 CAN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* U+19 EOM */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x24 U+84 IND */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x25 U+85 NEL */ (1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE),
/* 0x26 U+17 ETB */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* 0x27 U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* 0x27 U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL),
/* 0x28 U+88 HTS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x29 U+89 HTJ */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x2A U+8A VTS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x2C U+8C PLU */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x2D U+05 ENQ */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x2E U+06 ACK */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
-/* 0x2F U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
+/* 0x2F U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL),
/* 0x30 U+90 DCS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x31 U+91 PU1 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/* 0x32 U+16 SYN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA),
/SelfLoader.pm
/Socket.pm
/Storable.pm
+/Sub/
/Sys/
/TAP/
/Term/
OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
OPpSORT_REVERSE
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
+ SVpad_TYPED
CVf_METHOD CVf_LVALUE
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = '1.27';
+$VERSION = '1.28';
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
# curcvlex:
# Cached hash of lexical variables for curcv: keys are
# names prefixed with "m" or "o" (representing my/our), and
-# each value is an array of pairs, indicating the cop_seq of scopes
-# in which a var of that name is valid.
+# each value is an array with two elements indicating the cop_seq
+# of scopes in which a var of that name is valid and a third ele-
+# ment referencing the pad name.
#
# curcop:
# COP for statement being deparsed
}
}
+sub find_our_type {
+ my ($self, $name) = @_;
+ $self->populate_curcvlex() if !defined $self->{'curcvlex'};
+ my $seq = $self->{'curcop'}->cop_seq;
+ for my $a (@{$self->{'curcvlex'}{"o$name"}}) {
+ my ($st, undef, $padname) = @$a;
+ if ($st == $seq && $padname->FLAGS & SVpad_TYPED) {
+ return $padname->SvSTASH->NAME;
+ }
+ }
+ return '';
+}
+
sub maybe_local {
my $self = shift;
my($op, $cx, $text) = @_;
my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
- if ($op->private & (OPpLVAL_INTRO|$our_intro)
- and not $self->{'avoid_local'}{$$op}) {
+ if ($op->private & (OPpLVAL_INTRO|$our_intro)) {
my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
if( $our_local eq 'our' ) {
if ( $text !~ /^\W(\w+::)*\w+\z/
die "Unexpected our($text)\n";
}
$text =~ s/(\w+::)+//;
+
+ if (my $type = $self->find_our_type($text)) {
+ $our_local .= ' ' . $type;
+ }
}
+ return $text if $self->{'avoid_local'}{$$op};
if (want_scalar($op)) {
return "$our_local $text";
} else {
sub maybe_my {
my $self = shift;
- my($op, $cx, $text, $forbid_parens) = @_;
+ my($op, $cx, $padname, $forbid_parens) = @_;
+ my $text = $padname->PVX;
if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
my $my = $op->private & OPpPAD_STATE
? $self->keyword("state")
: "my";
+ if ($padname->FLAGS & SVpad_TYPED) {
+ $my .= ' ' . $padname->SvSTASH->NAME;
+ }
if ($forbid_parens || want_scalar($op)) {
return "$my $text";
} else {
my $self = shift;
my $gv = shift;
my $raw = shift;
-Carp::confess() unless ref($gv) eq "B::GV";
- my $stash = $gv->STASH->NAME;
- my $name = $raw ? $gv->NAME : $gv->SAFENAME;
+#Carp::confess() unless ref($gv) eq "B::GV";
+ my $cv = $gv->FLAGS & SVf_ROK ? $gv->RV : 0;
+ my $stash = ($cv || $gv)->STASH->NAME;
+ my $name = $raw
+ ? $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME
+ : $cv
+ ? B::safename($cv->NAME_HEK || $cv->GV->NAME)
+ : $gv->SAFENAME;
if ($stash eq 'main' && $name =~ /^::/) {
$stash = '::';
}
push @{$self->{'curcvlex'}{
($ns[$i]->FLAGS & SVpad_OUR ? 'o' : 'm') . $name
- }}, [$seq_st, $seq_en];
+ }}, [$seq_st, $seq_en, $ns[$i]];
}
}
}
return '' if class($kid) eq 'NULL';
my $lop;
my $local = "either"; # could be local(...), my(...), state(...) or our(...)
+ my $type;
for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
# This assumes that no other private flags equal 128, and that
# OPs that store things other than flags in their op_private,
# XXX This really needs to be rewritten to accept only those ops
# known to take the OPpLVAL_INTRO flag.
+ my $lopname = $lop->name;
if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
- or $lop->name eq "undef")
- or $lop->name =~ /^(?:entersub|exit|open|split)\z/)
+ or $lopname eq "undef")
+ or $lopname =~ /^(?:entersub|exit|open|split)\z/)
{
$local = ""; # or not
last;
}
- if ($lop->name =~ /^pad[ash]v$/) {
+ my $newtype;
+ if ($lopname =~ /^pad[ash]v$/) {
if ($lop->private & OPpPAD_STATE) { # state()
($local = "", last) if $local =~ /^(?:local|our|my)$/;
$local = "state";
($local = "", last) if $local =~ /^(?:local|our|state)$/;
$local = "my";
}
- } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
+ my $padname = $self->padname_sv($lop->targ);
+ if ($padname->FLAGS & SVpad_TYPED) {
+ $newtype = $padname->SvSTASH->NAME;
+ }
+ } elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/
&& $lop->private & OPpOUR_INTRO
- or $lop->name eq "null" && $lop->first->name eq "gvsv"
+ or $lopname eq "null" && $lop->first->name eq "gvsv"
&& $lop->first->private & OPpOUR_INTRO) { # our()
($local = "", last) if $local =~ /^(?:my|local|state)$/;
$local = "our";
- } elsif ($lop->name ne "undef"
+ my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%';
+ if (my $t = $self->find_our_type(
+ $funny . $self->gv_or_padgv($lop->first)->NAME
+ )) {
+ $newtype = $t;
+ }
+ } elsif ($lopname ne "undef"
# specifically avoid the "reverse sort" optimisation,
# where "reverse" is nullified
- && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
+ && !($lopname eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
{
# local()
($local = "", last) if $local =~ /^(?:my|our|state)$/;
$local = "local";
}
+ if (defined $type && defined $newtype && $newtype ne $type) {
+ $local = '';
+ last;
+ }
+ $type = $newtype;
}
$local = "" if $local eq "either"; # no point if it's all undefs
+ $local .= " $type " if $local && length $type;
return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
for (; !null($kid); $kid = $kid->sibling) {
if ($local) {
$ary = $self->deparse($ary, 1);
}
if (null $var) {
- if (($enter->flags & OPf_SPECIAL) && ($] < 5.009)) {
- # thread special var, under 5005threads
- $var = $self->pp_threadsv($enter, 1);
- } else { # regular my() variable
- $var = $self->pp_padsv($enter, 1, 1);
- }
+ $var = $self->pp_padsv($enter, 1, 1);
} elsif ($var->name eq "rv2gv") {
$var = $self->pp_rv2sv($var, 1);
if ($enter->private & OPpOUR_INTRO) {
sub pp_padsv {
my $self = shift;
my($op, $cx, $forbid_parens) = @_;
- return $self->maybe_my($op, $cx, $self->padname($op->targ),
+ return $self->maybe_my($op, $cx, $self->padname_sv($op->targ),
$forbid_parens);
}
sub pp_padav { pp_padsv(@_) }
sub pp_padhv { pp_padsv(@_) }
-my @threadsv_names = B::threadsv_names;
-sub pp_threadsv {
- my $self = shift;
- my($op, $cx) = @_;
- return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
-}
-
sub gv_or_padgv {
my $self = shift;
my $op = shift;
$kid = "{" . $self->deparse($kid, 0) . "}";
} elsif ($kid->first->name eq "gv") {
my $gv = $self->gv_or_padgv($kid->first);
- if (class($gv->CV) ne "SPECIAL") {
- $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
+ my $cv;
+ if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL"
+ || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') {
+ $proto = $cv->PV if $cv->FLAGS & SVf_POK;
}
$simple = 1; # only calls of named functions can be prototyped
$kid = $self->deparse($kid, 24);
my %x;
$x{warn()};
####
+# our (LIST)
+our($foo, $bar, $baz);
+####
+# CONTEXT { package Dog } use feature "state";
+# variables with declared classes
+my Dog $spot;
+our Dog $spotty;
+state Dog $spotted;
+my Dog @spot;
+our Dog @spotty;
+state Dog @spotted;
+my Dog %spot;
+our Dog %spotty;
+state Dog %spotted;
+my Dog ($foo, @bar, %baz);
+our Dog ($phoo, @barr, %bazz);
+state Dog ($fough, @barre, %bazze);
+####
# <>
my $foo;
$_ .= <ARGV> . <$foo>;
# [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns)
s/foo/\(3);/eg;
####
-# Test @threadsv_names under 5005threads
-foreach $' (1, 2) {
- sleep $';
-}
-####
# y///r
tr/a/b/r;
####
--- /dev/null
+# -*- buffer-read-only: t -*-
+#
+# lib/B/Op_private.pm
+#
+# Copyright (C) 2014 by Larry Wall and others
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is built by regen/opcode.pl from data in
+# regen/op_private and pod embedded in regen/opcode.pl.
+# Any changes made here will be lost!
+
+=head1 NAME
+
+B::Op_private - OP op_private flag definitions
+
+=head1 SYNOPSIS
+
+ use B::Op_private;
+
+ # flag details for bit 7 of OP_AELEM's op_private:
+ my $name = $B::Op_private::bits{aelem}{7}; # OPpLVAL_INTRO
+ my $value = $B::Op_private::defines{$name}; # 128
+ my $label = $B::Op_private::labels{$name}; # LVINTRO
+
+ # the bit field at bits 5..6 of OP_AELEM's op_private:
+ my $bf = $B::Op_private::bits{aelem}{6};
+ my $mask = $bf->{bitmask}; # etc
+
+=head1 DESCRIPTION
+
+This module provides three global hashes:
+
+ %B::Op_private::bits
+ %B::Op_private::defines
+ %B::Op_private::labels
+
+which contain information about the per-op meanings of the bits in the
+op_private field.
+
+=head2 C<%bits>
+
+This is indexed by op name and then bit number (0..7). For single bit flags,
+it returns the name of the define (if any) for that bit:
+
+ $B::Op_private::bits{aelem}{7} eq 'OPpLVAL_INTRO';
+
+For bit fields, it returns a hash ref containing details about the field.
+The same reference will be returned for all bit positions that make
+up the bit field; so for example these both return the same hash ref:
+
+ $bitfield = $B::Op_private::bits{aelem}{5};
+ $bitfield = $B::Op_private::bits{aelem}{6};
+
+The general format of this hash ref is
+
+ {
+ # The bit range and mask; these are always present.
+ bitmin => 5,
+ bitmax => 6,
+ bitmask => 0x60,
+
+ # (The remaining keys are optional)
+
+ # The names of any defines that were requested:
+ mask_def => 'OPpFOO_MASK',
+ baseshift_def => 'OPpFOO_SHIFT',
+ bitcount_def => 'OPpFOO_BITS',
+
+ # If present, Concise etc will display the value with a 'FOO='
+ # prefix. If it equals '-', then Concise will treat the bit
+ # field as raw bits and not try to interpret it.
+ label => 'FOO',
+
+ # If present, specifies the names of some defines and the
+ # display labels that are used to assign meaning to particu-
+ # lar integer values within the bit field; e.g. 3 is dis-
+ # played as 'C'.
+ enum => [ qw(
+ 1 OPpFOO_A A
+ 2 OPpFOO_B B
+ 3 OPpFOO_C C
+ )],
+
+ };
+
+
+=head2 C<%defines>
+
+This gives the value of every C<OPp> define, e.g.
+
+ $B::Op_private::defines{OPpLVAL_INTRO} == 128;
+
+=head2 C<%labels>
+
+This gives the short display label for each define, as used by C<B::Concise>
+and C<perl -Dx>, e.g.
+
+ $B::Op_private::labels{OPpLVAL_INTRO} eq 'LVINTRO';
+
+If the label equals '-', then Concise will treat the bit as a raw bit and
+not try to display it symbolically.
+
+=cut
+
+package B::Op_private;
+
+our %bits;
+
+
+our $VERSION = "5.021004";
+
+$bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv);
+$bits{$_}{4} = 'OPpENTERSUB_DB' for qw(entersub rv2cv);
+$bits{$_}{2} = 'OPpENTERSUB_HASTARG' for qw(entersub rv2cv);
+$bits{$_}{6} = 'OPpFLIP_LINENUM' for qw(flip flop);
+$bits{$_}{1} = 'OPpFT_ACCESS' for qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite);
+$bits{$_}{4} = 'OPpFT_AFTER_t' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
+$bits{$_}{2} = 'OPpFT_STACKED' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
+$bits{$_}{3} = 'OPpFT_STACKING' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
+$bits{$_}{1} = 'OPpGREP_LEX' for qw(grepstart grepwhile mapstart mapwhile);
+$bits{$_}{6} = 'OPpHINT_M_VMSISH_STATUS' for qw(dbstate nextstate);
+$bits{$_}{7} = 'OPpHINT_M_VMSISH_TIME' for qw(dbstate nextstate);
+$bits{$_}{1} = 'OPpHINT_STRICT_REFS' for qw(entersub rv2av rv2cv rv2gv rv2hv rv2sv);
+$bits{$_}{5} = 'OPpHUSH_VMSISH' for qw(dbstate nextstate);
+$bits{$_}{2} = 'OPpITER_REVERSED' for qw(enteriter iter);
+$bits{$_}{7} = 'OPpLVALUE' for qw(leave leaveloop);
+$bits{$_}{4} = 'OPpLVAL_DEFER' for qw(aelem helem);
+$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list padav padhv padrange padsv pos pushmark rv2av rv2gv rv2hv rv2sv substr vec);
+$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice padav padhv pos rkeys rv2av rv2gv rv2hv substr vec);
+$bits{$_}{6} = 'OPpMAYBE_TRUEBOOL' for qw(padhv rv2hv);
+$bits{$_}{7} = 'OPpOFFBYONE' for qw(caller runcv wantarray);
+$bits{$_}{5} = 'OPpOPEN_IN_CRLF' for qw(backtick open);
+$bits{$_}{4} = 'OPpOPEN_IN_RAW' for qw(backtick open);
+$bits{$_}{7} = 'OPpOPEN_OUT_CRLF' for qw(backtick open);
+$bits{$_}{6} = 'OPpOPEN_OUT_RAW' for qw(backtick open);
+$bits{$_}{4} = 'OPpOUR_INTRO' for qw(enteriter gvsv rv2av rv2hv rv2sv);
+$bits{$_}{4} = 'OPpPAD_STATE' for qw(padav padhv padsv pushmark);
+$bits{$_}{7} = 'OPpPV_IS_UTF8' for qw(dump goto last next redo);
+$bits{$_}{6} = 'OPpREFCOUNTED' for qw(leave leaveeval leavesub leavesublv leavewrite);
+$bits{$_}{6} = 'OPpRUNTIME' for qw(match pushre qr subst substcont);
+$bits{$_}{2} = 'OPpSLICEWARNING' for qw(aslice hslice padav padhv rv2av rv2hv);
+$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_negate i_postdec i_postinc i_subtract index int kill left_shift length link log match mkdir modulo multiply oct ord pow push rand rename right_shift rindex rmdir schomp setpgrp setpriority sin sleep sqrt srand stringify subst subtract symlink system time trans transr unlink unshift utime wait waitpid);
+$bits{$_}{5} = 'OPpTRANS_COMPLEMENT' for qw(trans transr);
+$bits{$_}{7} = 'OPpTRANS_DELETE' for qw(trans transr);
+$bits{$_}{0} = 'OPpTRANS_FROM_UTF' for qw(trans transr);
+$bits{$_}{6} = 'OPpTRANS_GROWS' for qw(trans transr);
+$bits{$_}{2} = 'OPpTRANS_IDENTICAL' for qw(trans transr);
+$bits{$_}{3} = 'OPpTRANS_SQUASH' for qw(trans transr);
+$bits{$_}{1} = 'OPpTRANS_TO_UTF' for qw(trans transr);
+$bits{$_}{5} = 'OPpTRUEBOOL' for qw(padhv rv2hv);
+
+my @bf = (
+ {
+ label => '-',
+ mask_def => 'OPpARG1_MASK',
+ bitmin => 0,
+ bitmax => 0,
+ bitmask => 1,
+ },
+ {
+ label => '-',
+ mask_def => 'OPpARG2_MASK',
+ bitmin => 0,
+ bitmax => 1,
+ bitmask => 3,
+ },
+ {
+ label => '-',
+ mask_def => 'OPpARG3_MASK',
+ bitmin => 0,
+ bitmax => 2,
+ bitmask => 7,
+ },
+ {
+ label => '-',
+ mask_def => 'OPpARG4_MASK',
+ bitmin => 0,
+ bitmax => 3,
+ bitmask => 15,
+ },
+ {
+ label => '-',
+ mask_def => 'OPpPADRANGE_COUNTMASK',
+ bitcount_def => 'OPpPADRANGE_COUNTSHIFT',
+ bitmin => 0,
+ bitmax => 6,
+ bitmask => 127,
+ },
+ {
+ label => '-',
+ bitmin => 0,
+ bitmax => 7,
+ bitmask => 255,
+ },
+ {
+ mask_def => 'OPpDEREF',
+ bitmin => 5,
+ bitmax => 6,
+ bitmask => 96,
+ enum => [
+ 1, 'OPpDEREF_AV', 'DREFAV',
+ 2, 'OPpDEREF_HV', 'DREFHV',
+ 3, 'OPpDEREF_SV', 'DREFSV',
+ ],
+ },
+);
+
+@{$bits{aassign}}{6,1,0} = ('OPpASSIGN_COMMON', $bf[1], $bf[1]);
+$bits{abs}{0} = $bf[0];
+@{$bits{accept}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{add}}{1,0} = ($bf[1], $bf[1]);
+$bits{aeach}{0} = $bf[0];
+@{$bits{aelem}}{6,5,1,0} = ($bf[6], $bf[6], $bf[1], $bf[1]);
+@{$bits{aelemfast}}{7,6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]);
+@{$bits{aelemfast_lex}}{7,6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]);
+$bits{akeys}{0} = $bf[0];
+$bits{alarm}{0} = $bf[0];
+$bits{and}{0} = $bf[0];
+$bits{andassign}{0} = $bf[0];
+@{$bits{anonhash}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{anonlist}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{atan2}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{av2arylen}{0} = $bf[0];
+$bits{avalues}{0} = $bf[0];
+$bits{backtick}{0} = $bf[0];
+@{$bits{bind}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{binmode}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{bit_and}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{bit_or}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{bit_xor}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{bless}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{caller}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{chdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{chmod}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{chomp}{0} = $bf[0];
+$bits{chop}{0} = $bf[0];
+@{$bits{chown}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{chr}{0} = $bf[0];
+$bits{chroot}{0} = $bf[0];
+@{$bits{close}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{closedir}{0} = $bf[0];
+$bits{complement}{0} = $bf[0];
+@{$bits{concat}}{1,0} = ($bf[1], $bf[1]);
+$bits{cond_expr}{0} = $bf[0];
+@{$bits{connect}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{const}}{6,4,3,2,1} = ('OPpCONST_BARE', 'OPpCONST_ENTERED', 'OPpCONST_STRICT', 'OPpCONST_SHORTCIRCUIT', 'OPpCONST_NOVER');
+@{$bits{coreargs}}{7,6,1,0} = ('OPpCOREARGS_PUSHMARK', 'OPpCOREARGS_SCALARMOD', 'OPpCOREARGS_DEREF2', 'OPpCOREARGS_DEREF1');
+$bits{cos}{0} = $bf[0];
+@{$bits{crypt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{dbmclose}{0} = $bf[0];
+@{$bits{dbmopen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{defined}{0} = $bf[0];
+@{$bits{delete}}{6,0} = ('OPpSLICE', $bf[0]);
+@{$bits{die}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{divide}}{1,0} = ($bf[1], $bf[1]);
+$bits{dofile}{0} = $bf[0];
+$bits{dor}{0} = $bf[0];
+$bits{dorassign}{0} = $bf[0];
+$bits{dump}{0} = $bf[0];
+$bits{each}{0} = $bf[0];
+@{$bits{entereval}}{5,4,3,2,1,0} = ('OPpEVAL_RE_REPARSING', 'OPpEVAL_COPHH', 'OPpEVAL_BYTES', 'OPpEVAL_UNICODE', 'OPpEVAL_HAS_HH', $bf[0]);
+$bits{entergiven}{0} = $bf[0];
+$bits{enteriter}{3} = 'OPpITER_DEF';
+@{$bits{entersub}}{6,5,0} = ($bf[6], $bf[6], 'OPpENTERSUB_INARGS');
+$bits{entertry}{0} = $bf[0];
+$bits{enterwhen}{0} = $bf[0];
+@{$bits{enterwrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{eof}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{eq}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{exec}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{exists}}{6,0} = ('OPpEXISTS_SUB', $bf[0]);
+@{$bits{exit}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{exp}{0} = $bf[0];
+$bits{fc}{0} = $bf[0];
+@{$bits{fcntl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{fileno}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{flip}{0} = $bf[0];
+@{$bits{flock}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{flop}{0} = $bf[0];
+@{$bits{formline}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{ftatime}{0} = $bf[0];
+$bits{ftbinary}{0} = $bf[0];
+$bits{ftblk}{0} = $bf[0];
+$bits{ftchr}{0} = $bf[0];
+$bits{ftctime}{0} = $bf[0];
+$bits{ftdir}{0} = $bf[0];
+$bits{fteexec}{0} = $bf[0];
+$bits{fteowned}{0} = $bf[0];
+$bits{fteread}{0} = $bf[0];
+$bits{ftewrite}{0} = $bf[0];
+$bits{ftfile}{0} = $bf[0];
+$bits{ftis}{0} = $bf[0];
+$bits{ftlink}{0} = $bf[0];
+$bits{ftmtime}{0} = $bf[0];
+$bits{ftpipe}{0} = $bf[0];
+$bits{ftrexec}{0} = $bf[0];
+$bits{ftrowned}{0} = $bf[0];
+$bits{ftrread}{0} = $bf[0];
+$bits{ftrwrite}{0} = $bf[0];
+$bits{ftsgid}{0} = $bf[0];
+$bits{ftsize}{0} = $bf[0];
+$bits{ftsock}{0} = $bf[0];
+$bits{ftsuid}{0} = $bf[0];
+$bits{ftsvtx}{0} = $bf[0];
+$bits{fttext}{0} = $bf[0];
+$bits{fttty}{0} = $bf[0];
+$bits{ftzero}{0} = $bf[0];
+@{$bits{ge}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{gelem}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{getc}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{getpeername}{0} = $bf[0];
+@{$bits{getpgrp}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{getpriority}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{getsockname}{0} = $bf[0];
+$bits{ggrgid}{0} = $bf[0];
+$bits{ggrnam}{0} = $bf[0];
+@{$bits{ghbyaddr}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{ghbyname}{0} = $bf[0];
+@{$bits{glob}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{gmtime}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{gnbyaddr}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{gnbyname}{0} = $bf[0];
+$bits{goto}{0} = $bf[0];
+$bits{gpbyname}{0} = $bf[0];
+@{$bits{gpbynumber}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{gpwnam}{0} = $bf[0];
+$bits{gpwuid}{0} = $bf[0];
+$bits{grepwhile}{0} = $bf[0];
+@{$bits{gsbyname}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{gsbyport}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{gsockopt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{gt}}{1,0} = ($bf[1], $bf[1]);
+$bits{gv}{5} = 'OPpEARLY_CV';
+@{$bits{helem}}{6,5,1,0} = ($bf[6], $bf[6], $bf[1], $bf[1]);
+$bits{hex}{0} = $bf[0];
+@{$bits{i_add}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_divide}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_eq}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_ge}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_gt}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_le}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_lt}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_modulo}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_multiply}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_ncmp}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{i_ne}}{1,0} = ($bf[1], $bf[1]);
+$bits{i_negate}{0} = $bf[0];
+$bits{i_postdec}{0} = $bf[0];
+$bits{i_postinc}{0} = $bf[0];
+$bits{i_predec}{0} = $bf[0];
+$bits{i_preinc}{0} = $bf[0];
+@{$bits{i_subtract}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{index}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{int}{0} = $bf[0];
+@{$bits{ioctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{join}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{keys}{0} = $bf[0];
+@{$bits{kill}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{last}{0} = $bf[0];
+$bits{lc}{0} = $bf[0];
+$bits{lcfirst}{0} = $bf[0];
+@{$bits{le}}{1,0} = ($bf[1], $bf[1]);
+$bits{leaveeval}{0} = $bf[0];
+$bits{leavegiven}{0} = $bf[0];
+@{$bits{leaveloop}}{1,0} = ($bf[1], $bf[1]);
+$bits{leavesub}{0} = $bf[0];
+$bits{leavesublv}{0} = $bf[0];
+$bits{leavewhen}{0} = $bf[0];
+$bits{leavewrite}{0} = $bf[0];
+@{$bits{left_shift}}{1,0} = ($bf[1], $bf[1]);
+$bits{length}{0} = $bf[0];
+@{$bits{link}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{list}{6} = 'OPpLIST_GUESSED';
+@{$bits{listen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{localtime}{0} = $bf[0];
+$bits{lock}{0} = $bf[0];
+$bits{log}{0} = $bf[0];
+@{$bits{lslice}}{1,0} = ($bf[1], $bf[1]);
+$bits{lstat}{0} = $bf[0];
+@{$bits{lt}}{1,0} = ($bf[1], $bf[1]);
+$bits{mapwhile}{0} = $bf[0];
+$bits{method}{0} = $bf[0];
+@{$bits{mkdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{modulo}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{msgctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{msgget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{msgrcv}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{msgsnd}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{multiply}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{ncmp}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{ne}}{1,0} = ($bf[1], $bf[1]);
+$bits{negate}{0} = $bf[0];
+$bits{next}{0} = $bf[0];
+$bits{not}{0} = $bf[0];
+$bits{oct}{0} = $bf[0];
+$bits{once}{0} = $bf[0];
+@{$bits{open}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{open_dir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{or}{0} = $bf[0];
+$bits{orassign}{0} = $bf[0];
+$bits{ord}{0} = $bf[0];
+@{$bits{pack}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{padrange}}{6,5,4,3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4], $bf[4], $bf[4], $bf[4]);
+@{$bits{padsv}}{6,5} = ($bf[6], $bf[6]);
+@{$bits{pipe_op}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{pop}{0} = $bf[0];
+$bits{pos}{0} = $bf[0];
+$bits{postdec}{0} = $bf[0];
+$bits{postinc}{0} = $bf[0];
+@{$bits{pow}}{1,0} = ($bf[1], $bf[1]);
+$bits{predec}{0} = $bf[0];
+$bits{preinc}{0} = $bf[0];
+$bits{prototype}{0} = $bf[0];
+@{$bits{push}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{quotemeta}{0} = $bf[0];
+@{$bits{rand}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{range}{0} = $bf[0];
+$bits{reach}{0} = $bf[0];
+@{$bits{read}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{readdir}{0} = $bf[0];
+$bits{readline}{0} = $bf[0];
+$bits{readlink}{0} = $bf[0];
+@{$bits{recv}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{redo}{0} = $bf[0];
+$bits{ref}{0} = $bf[0];
+$bits{refgen}{0} = $bf[0];
+$bits{regcmaybe}{0} = $bf[0];
+$bits{regcomp}{0} = $bf[0];
+$bits{regcreset}{0} = $bf[0];
+@{$bits{rename}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{repeat}}{6,1,0} = ('OPpREPEAT_DOLIST', $bf[1], $bf[1]);
+$bits{require}{0} = $bf[0];
+@{$bits{reset}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{reverse}}{3,0} = ('OPpREVERSE_INPLACE', $bf[0]);
+$bits{rewinddir}{0} = $bf[0];
+@{$bits{right_shift}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{rindex}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{rkeys}{0} = $bf[0];
+$bits{rmdir}{0} = $bf[0];
+$bits{rv2av}{0} = $bf[0];
+@{$bits{rv2cv}}{7,6,0} = ('OPpENTERSUB_NOPAREN', 'OPpMAY_RETURN_CONSTANT', $bf[0]);
+@{$bits{rv2gv}}{6,5,4,2,0} = ($bf[6], $bf[6], 'OPpALLOW_FAKE', 'OPpDONT_INIT_GV', $bf[0]);
+$bits{rv2hv}{0} = $bf[0];
+@{$bits{rv2sv}}{6,5,0} = ($bf[6], $bf[6], $bf[0]);
+$bits{rvalues}{0} = $bf[0];
+@{$bits{sassign}}{7,6,1,0} = ('OPpASSIGN_CV_TO_GV', 'OPpASSIGN_BACKWARDS', $bf[1], $bf[1]);
+$bits{scalar}{0} = $bf[0];
+$bits{schomp}{0} = $bf[0];
+$bits{schop}{0} = $bf[0];
+@{$bits{scmp}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{seek}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{seekdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{select}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{semctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{semget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{semop}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{send}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{seq}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{setpgrp}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{setpriority}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sge}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{sgt}}{1,0} = ($bf[1], $bf[1]);
+$bits{shift}{0} = $bf[0];
+@{$bits{shmctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{shmget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{shmread}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{shmwrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{shostent}{0} = $bf[0];
+@{$bits{shutdown}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{sin}{0} = $bf[0];
+@{$bits{sle}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{sleep}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{slt}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{smartmatch}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{sne}}{1,0} = ($bf[1], $bf[1]);
+$bits{snetent}{0} = $bf[0];
+@{$bits{socket}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sockpair}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sort}}{6,5,4,3,2,1,0} = ('OPpSORT_STABLE', 'OPpSORT_QSORT', 'OPpSORT_DESCEND', 'OPpSORT_INPLACE', 'OPpSORT_REVERSE', 'OPpSORT_INTEGER', 'OPpSORT_NUMERIC');
+@{$bits{splice}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{split}{7} = 'OPpSPLIT_IMPLIM';
+@{$bits{sprintf}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{sprotoent}{0} = $bf[0];
+$bits{sqrt}{0} = $bf[0];
+@{$bits{srand}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{srefgen}{0} = $bf[0];
+@{$bits{sselect}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{sservent}{0} = $bf[0];
+@{$bits{ssockopt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{stat}{0} = $bf[0];
+@{$bits{stringify}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{study}{0} = $bf[0];
+$bits{substcont}{0} = $bf[0];
+@{$bits{substr}}{4,2,1,0} = ('OPpSUBSTR_REPL_FIRST', $bf[2], $bf[2], $bf[2]);
+@{$bits{subtract}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{symlink}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{syscall}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sysopen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sysread}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{sysseek}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{system}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{syswrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{tell}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{telldir}{0} = $bf[0];
+@{$bits{tie}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{tied}{0} = $bf[0];
+@{$bits{truncate}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{uc}{0} = $bf[0];
+$bits{ucfirst}{0} = $bf[0];
+@{$bits{umask}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{undef}{0} = $bf[0];
+@{$bits{unlink}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{unpack}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{unshift}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{untie}{0} = $bf[0];
+@{$bits{utime}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+$bits{values}{0} = $bf[0];
+@{$bits{vec}}{1,0} = ($bf[1], $bf[1]);
+@{$bits{waitpid}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{warn}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
+@{$bits{xor}}{1,0} = ($bf[1], $bf[1]);
+
+
+our %defines = (
+ OPpALLOW_FAKE => 16,
+ OPpARG1_MASK => 1,
+ OPpARG2_MASK => 3,
+ OPpARG3_MASK => 7,
+ OPpARG4_MASK => 15,
+ OPpASSIGN_BACKWARDS => 64,
+ OPpASSIGN_COMMON => 64,
+ OPpASSIGN_CV_TO_GV => 128,
+ OPpCONST_BARE => 64,
+ OPpCONST_ENTERED => 16,
+ OPpCONST_NOVER => 2,
+ OPpCONST_SHORTCIRCUIT => 4,
+ OPpCONST_STRICT => 8,
+ OPpCOREARGS_DEREF1 => 1,
+ OPpCOREARGS_DEREF2 => 2,
+ OPpCOREARGS_PUSHMARK => 128,
+ OPpCOREARGS_SCALARMOD => 64,
+ OPpDEREF => 96,
+ OPpDEREF_AV => 32,
+ OPpDEREF_HV => 64,
+ OPpDEREF_SV => 96,
+ OPpDONT_INIT_GV => 4,
+ OPpEARLY_CV => 32,
+ OPpENTERSUB_AMPER => 8,
+ OPpENTERSUB_DB => 16,
+ OPpENTERSUB_HASTARG => 4,
+ OPpENTERSUB_INARGS => 1,
+ OPpENTERSUB_NOPAREN => 128,
+ OPpEVAL_BYTES => 8,
+ OPpEVAL_COPHH => 16,
+ OPpEVAL_HAS_HH => 2,
+ OPpEVAL_RE_REPARSING => 32,
+ OPpEVAL_UNICODE => 4,
+ OPpEXISTS_SUB => 64,
+ OPpFLIP_LINENUM => 64,
+ OPpFT_ACCESS => 2,
+ OPpFT_AFTER_t => 16,
+ OPpFT_STACKED => 4,
+ OPpFT_STACKING => 8,
+ OPpGREP_LEX => 2,
+ OPpHINT_M_VMSISH_STATUS => 64,
+ OPpHINT_M_VMSISH_TIME => 128,
+ OPpHINT_STRICT_REFS => 2,
+ OPpHUSH_VMSISH => 32,
+ OPpITER_DEF => 8,
+ OPpITER_REVERSED => 4,
+ OPpLIST_GUESSED => 64,
+ OPpLVALUE => 128,
+ OPpLVAL_DEFER => 16,
+ OPpLVAL_INTRO => 128,
+ OPpMAYBE_LVSUB => 8,
+ OPpMAYBE_TRUEBOOL => 64,
+ OPpMAY_RETURN_CONSTANT => 64,
+ OPpOFFBYONE => 128,
+ OPpOPEN_IN_CRLF => 32,
+ OPpOPEN_IN_RAW => 16,
+ OPpOPEN_OUT_CRLF => 128,
+ OPpOPEN_OUT_RAW => 64,
+ OPpOUR_INTRO => 16,
+ OPpPADRANGE_COUNTMASK => 127,
+ OPpPADRANGE_COUNTSHIFT => 7,
+ OPpPAD_STATE => 16,
+ OPpPV_IS_UTF8 => 128,
+ OPpREFCOUNTED => 64,
+ OPpREPEAT_DOLIST => 64,
+ OPpREVERSE_INPLACE => 8,
+ OPpRUNTIME => 64,
+ OPpSLICE => 64,
+ OPpSLICEWARNING => 4,
+ OPpSORT_DESCEND => 16,
+ OPpSORT_INPLACE => 8,
+ OPpSORT_INTEGER => 2,
+ OPpSORT_NUMERIC => 1,
+ OPpSORT_QSORT => 32,
+ OPpSORT_REVERSE => 4,
+ OPpSORT_STABLE => 64,
+ OPpSPLIT_IMPLIM => 128,
+ OPpSUBSTR_REPL_FIRST => 16,
+ OPpTARGET_MY => 16,
+ OPpTRANS_COMPLEMENT => 32,
+ OPpTRANS_DELETE => 128,
+ OPpTRANS_FROM_UTF => 1,
+ OPpTRANS_GROWS => 64,
+ OPpTRANS_IDENTICAL => 4,
+ OPpTRANS_SQUASH => 8,
+ OPpTRANS_TO_UTF => 2,
+ OPpTRUEBOOL => 32,
+);
+
+our %labels = (
+ OPpALLOW_FAKE => 'FAKE',
+ OPpASSIGN_BACKWARDS => 'BKWARD',
+ OPpASSIGN_COMMON => 'COMMON',
+ OPpASSIGN_CV_TO_GV => 'CV2GV',
+ OPpCONST_BARE => 'BARE',
+ OPpCONST_ENTERED => 'ENTERED',
+ OPpCONST_NOVER => 'NOVER',
+ OPpCONST_SHORTCIRCUIT => 'SHORT',
+ OPpCONST_STRICT => 'STRICT',
+ OPpCOREARGS_DEREF1 => 'DEREF1',
+ OPpCOREARGS_DEREF2 => 'DEREF2',
+ OPpCOREARGS_PUSHMARK => 'MARK',
+ OPpCOREARGS_SCALARMOD => '$MOD',
+ OPpDEREF_AV => 'DREFAV',
+ OPpDEREF_HV => 'DREFHV',
+ OPpDEREF_SV => 'DREFSV',
+ OPpDONT_INIT_GV => 'NOINIT',
+ OPpEARLY_CV => 'EARLYCV',
+ OPpENTERSUB_AMPER => 'AMPER',
+ OPpENTERSUB_DB => 'DBG',
+ OPpENTERSUB_HASTARG => 'TARG',
+ OPpENTERSUB_INARGS => 'INARGS',
+ OPpENTERSUB_NOPAREN => 'NO()',
+ OPpEVAL_BYTES => 'BYTES',
+ OPpEVAL_COPHH => 'COPHH',
+ OPpEVAL_HAS_HH => 'HAS_HH',
+ OPpEVAL_RE_REPARSING => 'REPARSE',
+ OPpEVAL_UNICODE => 'UNI',
+ OPpEXISTS_SUB => 'SUB',
+ OPpFLIP_LINENUM => 'LINENUM',
+ OPpFT_ACCESS => 'FTACCESS',
+ OPpFT_AFTER_t => 'FTAFTERt',
+ OPpFT_STACKED => 'FTSTACKED',
+ OPpFT_STACKING => 'FTSTACKING',
+ OPpGREP_LEX => 'GREPLEX',
+ OPpHINT_M_VMSISH_STATUS => 'VMSISH_STATUS',
+ OPpHINT_M_VMSISH_TIME => 'VMSISH_TIME',
+ OPpHINT_STRICT_REFS => 'STRICT',
+ OPpHUSH_VMSISH => 'HUSH',
+ OPpITER_DEF => 'DEF',
+ OPpITER_REVERSED => 'REVERSED',
+ OPpLIST_GUESSED => 'GUESSED',
+ OPpLVALUE => 'LV',
+ OPpLVAL_DEFER => 'LVDEFER',
+ OPpLVAL_INTRO => 'LVINTRO',
+ OPpMAYBE_LVSUB => 'LVSUB',
+ OPpMAYBE_TRUEBOOL => 'BOOL?',
+ OPpMAY_RETURN_CONSTANT => 'CONST',
+ OPpOFFBYONE => '+1',
+ OPpOPEN_IN_CRLF => 'INCR',
+ OPpOPEN_IN_RAW => 'INBIN',
+ OPpOPEN_OUT_CRLF => 'OUTCR',
+ OPpOPEN_OUT_RAW => 'OUTBIN',
+ OPpOUR_INTRO => 'OURINTR',
+ OPpPAD_STATE => 'STATE',
+ OPpPV_IS_UTF8 => 'UTF',
+ OPpREFCOUNTED => 'REFC',
+ OPpREPEAT_DOLIST => 'DOLIST',
+ OPpREVERSE_INPLACE => 'INPLACE',
+ OPpRUNTIME => 'RTIME',
+ OPpSLICE => 'SLICE',
+ OPpSLICEWARNING => 'SLICEWARN',
+ OPpSORT_DESCEND => 'DESC',
+ OPpSORT_INPLACE => 'INPLACE',
+ OPpSORT_INTEGER => 'INT',
+ OPpSORT_NUMERIC => 'NUM',
+ OPpSORT_QSORT => 'QSORT',
+ OPpSORT_REVERSE => 'REV',
+ OPpSORT_STABLE => 'STABLE',
+ OPpSPLIT_IMPLIM => 'IMPLIM',
+ OPpSUBSTR_REPL_FIRST => 'REPL1ST',
+ OPpTARGET_MY => 'TARGMY',
+ OPpTRANS_COMPLEMENT => 'COMPL',
+ OPpTRANS_DELETE => 'DEL',
+ OPpTRANS_FROM_UTF => '<UTF',
+ OPpTRANS_GROWS => 'GROWS',
+ OPpTRANS_IDENTICAL => 'IDENT',
+ OPpTRANS_SQUASH => 'SQUASH',
+ OPpTRANS_TO_UTF => '>UTF',
+ OPpTRUEBOOL => 'BOOL',
+);
+
+# ex: set ro:
The C<getopt()> function is similar, but its argument is a string containing
all switches that take an argument. If no argument is provided for a switch,
say, C<y>, the corresponding C<$opt_y> will be set to an undefined value.
-Unspecified switches are silently accepted. B<Use of C<getopts()> is not
-recommended.>
+Unspecified switches are silently accepted. Use of C<getopt()> is not
+recommended.
Note that, if your code is running under the recommended C<use strict
vars> pragma, you will need to declare these package variables
@ISA = qw(Exporter);
@EXPORT = qw(getopt getopts);
-$VERSION = '1.10';
+$VERSION = '1.11';
# uncomment the next line to disable 1.03-backward compatibility paranoia
# $STANDARD_HELP_VERSION = 1;
package _charnames;
use strict;
use warnings;
-use File::Spec;
-our $VERSION = '1.41';
+our $VERSION = '1.42';
use unicore::Name; # mktables-generated algorithmically-defined names
use bytes (); # for $bytes::hint_bits
sub alias_file ($) # Reads a file containing alias definitions
{
+ require File::Spec;
my ($arg, $file) = @_;
if (-f $arg && File::Spec->file_name_is_absolute ($arg)) {
$file = $arg;
$warning = '';
warn "Using just the first character returned by \\N{} in character class in regex; marked by <-- HERE in m/%s/";
like $warning,
- qr/A charnames handler may return a sequence/s,
+ qr/Named Unicode character escapes/s,
'multi-line entries in perldiag.pod match';
# ; at end of entry in perldiag.pod
my $first_c_test = $locales_test_number;
- report_result($Locale, ++$locales_test_number, $ok3);
- $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a constant';
- $problematical_tests{$locales_test_number} = 1;
+ $test_names{++$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a constant';
+ if ($Config{usequadmath}) {
+ print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
+ report_result($Locale, $locales_test_number, 1);
+ } else {
+ report_result($Locale, $locales_test_number, $ok3);
+ $problematical_tests{$locales_test_number} = 1;
+ }
- report_result($Locale, ++$locales_test_number, $ok4);
- $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar';
- $problematical_tests{$locales_test_number} = 1;
+ $test_names{++$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar';
+ if ($Config{usequadmath}) {
+ print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
+ report_result($Locale, $locales_test_number, 1);
+ } else {
+ report_result($Locale, $locales_test_number, $ok4);
+ $problematical_tests{$locales_test_number} = 1;
+ }
report_result($Locale, ++$locales_test_number, $ok5);
$test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar and an intervening sprintf';
report_result($Locale, ++$locales_test_number, $ok7);
$test_names{$locales_test_number} = 'Verify that "==" with a scalar still works in inner no locale';
- report_result($Locale, ++$locales_test_number, $ok8);
- $test_names{$locales_test_number} = 'Verify that "==" with a scalar and an intervening sprintf still works in inner no locale';
- $problematical_tests{$locales_test_number} = 1;
+ $test_names{++$locales_test_number} = 'Verify that "==" with a scalar and an intervening sprintf still works in inner no locale';
+ if ($Config{usequadmath}) {
+ print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
+ report_result($Locale, $locales_test_number, 1);
+ } else {
+ report_result($Locale, $locales_test_number, $ok8);
+ $problematical_tests{$locales_test_number} = 1;
+ }
debug "$first_e_test..$locales_test_number: \$e = $e, no locale\n";
$test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar';
$problematical_tests{$locales_test_number} = 1;
- report_result($Locale, ++$locales_test_number, $ok11);
- $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar and an intervening sprintf';
- $problematical_tests{$locales_test_number} = 1;
+ $test_names{++$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar and an intervening sprintf';
+ if ($Config{usequadmath}) {
+ print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n";
+ report_result($Locale, $locales_test_number, 1);
+ } else {
+ report_result($Locale, $locales_test_number, $ok11);
+ $problematical_tests{$locales_test_number} = 1;
+ }
report_result($Locale, ++$locales_test_number, $ok12);
$test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix can participate in an addition and function call as numeric';
}
}
- report_result($Locale, $locales_test_number, @f == 0);
- if (@f) {
- print "# failed $locales_test_number locale '$Locale' numbers @f\n"
+ if ($Config{usequadmath}) {
+ print "# Skip: no locale radix with usequadmath ($Locale)\n";
+ report_result($Locale, $locales_test_number, 1);
+ } else {
+ report_result($Locale, $locales_test_number, @f == 0);
+ if (@f) {
+ print "# failed $locales_test_number locale '$Locale' numbers @f\n"
+ }
}
}
}
package overload;
-our $VERSION = '1.22';
+our $VERSION = '1.23';
%ops = (
with_assign => "+ - * / % ** << >> x .",
return undef unless $globref;
my $sub = \&{*$globref};
no overloading;
- return $sub if !ref $sub or $sub != \&nil;
+ return $sub if $sub != \&nil;
return shift->can($ {*$globref});
}
$| = 1;
BEGIN { require './test.pl' }
-plan tests => 5194;
+plan tests => 5198;
use Scalar::Util qw(tainted);
pass("RT 121362");
}
+package refsgalore {
+ use overload
+ '${}' => sub { \42 },
+ '@{}' => sub { [43] },
+ '%{}' => sub { { 44 => 45 } },
+ '&{}' => sub { sub { 46 } };
+}
+{
+ use feature 'postderef';
+ no warnings 'experimental::postderef';
+ tell myio; # vivifies *myio{IO} at compile time
+ use constant ioref => bless *myio{IO}, refsgalore::;
+ is ioref->$*, 42, '(overloaded constant that is not a scalar ref)->$*';
+ is ioref->[0], 43, '(ovrld constant that is not an array ref)->[0]';
+ is ioref->{44}, 45, "(ovrld const that is not a hash ref)->{key}";
+ is ioref->(), 46, '(overloaded constant that is not a sub ref)->()';
+}
{ # undefining the overload stash -- KEEP THIS TEST LAST
package ant;
}
if (miniperl) {
eval "require '$unicore_dir/Heavy.pl'";
- last GETFILE if $@;
+ if ($@) {
+ print STDERR __LINE__, ": '$@'\n" if DEBUG;
+ pop @recursed if @recursed;
+ return $type;
+ }
}
else {
require "$unicore_dir/Heavy.pl";
while ((name += strcspn(name, "Uu") + 1)
<= save_input_locale + final_pos - 2)
{
- if (toFOLD(*(name)) != 't'
- || toFOLD(*(name + 1)) != 'f')
+ if (!isALPHA_FOLD_NE(*name, 't')
+ || isALPHA_FOLD_NE(*(name + 1), 'f'))
{
continue;
}
}
unless ($fromname) {
- die "For $mname tried @locations in in $ext_dir but can't find source";
+ die "For $mname tried @locations in $ext_dir but can't find source";
}
($value = $fromname) =~ s/\.pm\z/.pod/;
$value = $fromname unless -e $value;
# the Makefile.PL. Altering the atime and mtime backwards by 4
# seconds seems to resolve the issue.
eval {
- my $ftime = time - 4;
- utime $ftime, $ftime, 'Makefile.PL';
+ my $ftime = (stat('Makefile.PL'))[9] - 4;
+ utime $ftime, $ftime, 'Makefile.PL';
};
} elsif ($mname =~ /\A(?:Carp
|ExtUtils::CBuilder
# Remaining remnants that _may_ be functions are handled below.
}
+unless ($define{'USE_QUADMATH'}) {
+ ++$skip{Perl_quadmath_format_needed};
+ ++$skip{Perl_quadmath_format_single};
+}
+
###############################################################################
# At this point all skip lists should be completed, as we are about to test
return NATIVE_TO_UNI(valid_utf8_to_uvchr(s, retlen));
}
+void
+Perl_save_re_context(pTHX)
+{
+ PERL_UNUSED_CONTEXT;
+}
+
+
END_EXTERN_C
#endif /* NO_MATHOMS */
* in Configure, this is the way to force them into availability.
*
* BOOTSTRAP_CHARSET
- * CHARBITS
+ * HAS_ACOSH
* HAS_ASCTIME64
- * HAS_BACKTRACE
* HAS_CTIME64
* HAS_DIFFTIME64
* HAS_DLADDR
+ * HAS_FEGETROUND
+ * HAS_FPCLASSIFY
* HAS_GMTIME64
- * HAS_ISBLANK
+ * HAS_ISFINITEL
+ * HAS_ISINFL
+ * HAS_J0
* HAS_LOCALTIME64
- * HAS_IP_MREQ
- * HAS_IP_MREQ_SOURCE
- * HAS_IPV6_MREQ
- * HAS_IPV6_MREQ_SOURCE
* HAS_MKTIME64
* HAS_PRCTL
* HAS_PSEUDOFORK
* HAS_TIMEGM
- * HAS_SOCKADDR_IN6
* I16SIZE
* I64SIZE
* I8SIZE
* LOCALTIME_R_NEEDS_TZSET
* U8SIZE
* USE_CBACKTRACE
- * USE_KERN_PROC_PATHNAME
- * USE_NSGETEXECUTABLEPATH
- *
*/
if (flags & G_WRITING_TO_STDERR) {
SAVETMPS;
- save_re_context();
SAVESPTR(PL_stderrgv);
PL_stderrgv = NULL;
}
PERL_UNUSED_ARG(mg);
#endif
- TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
+ TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
return 0;
}
}
if (!cv || !CvROOT(cv)) {
- Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
- PL_sig_name[sig], (gv ? GvENAME(gv)
- : ((cv && CvGV(cv))
- ? GvENAME(CvGV(cv))
- : "__ANON__")));
+ const HEK * const hek = gv
+ ? GvENAME_HEK(gv)
+ : cv && CvNAMED(cv)
+ ? CvNAME_HEK(cv)
+ : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
+ if (hek)
+ Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
+ "SIG%s handler \"%"HEKf"\" not defined.\n",
+ PL_sig_name[sig], hek);
+ /* diag_listed_as: SIG%s handler "%s" not defined */
+ else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
+ "SIG%s handler \"__ANON__\" not defined.\n",
+ PL_sig_name[sig]);
goto cleanup;
}
#define MGf_TAINTEDDIR 1 /* PERL_MAGIC_envelem only */
#define MGf_MINMATCH 1 /* PERL_MAGIC_regex_global only */
+#define MGf_REQUIRE_GV 1 /* PERL_MAGIC_checkcall only */
#define MGf_REFCOUNTED 2
#define MGf_GSKIP 4 /* skip further GETs until after next SET */
#define MGf_COPY 8 /* has an svt_copy MGVTBL entry */
HEK *const key = HeKEY_hek(he);
HeVAL(he) = &PL_sv_undef;
- /* Save copying by making a shared hash key scalar. We
- inline this here rather than calling
- Perl_newSVpvn_share because we already have the
- scalar, and we already have the hash key. */
- assert(SvTYPE(val) == SVt_NULL);
- sv_upgrade(val, SVt_PV);
- SvPV_set(val, HEK_KEY(share_hek_hek(key)));
- SvCUR_set(val, HEK_LEN(key));
- SvIsCOW_on(val);
- SvPOK_on(val);
- if (HEK_UTF8(key))
- SvUTF8_on(val);
-
+ sv_sethek(val, key);
av_push(retval, val);
}
}
for compatibility silently suffer "b" and "0b" as valid binary
numbers. */
if (len >= 1) {
- if (s[0] == 'b' || s[0] == 'B') {
+ if (isALPHA_FOLD_EQ(s[0], 'b')) {
s++;
len--;
}
- else if (len >= 2 && s[0] == '0' && (s[1] == 'b' || s[1] == 'B')) {
+ else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'b'))) {
s+=2;
len-=2;
}
=cut
Not documented yet because experimental is C<PERL_SCAN_SILENT_NON_PORTABLE
-which suppresses any message for non-portable numbers that are still valid
+which suppresses any message for non-portable numbers, but which are valid
on this platform.
*/
for compatibility silently suffer "x" and "0x" as valid hex numbers.
*/
if (len >= 1) {
- if (s[0] == 'x' || s[0] == 'X') {
+ if (isALPHA_FOLD_EQ(s[0], 'x')) {
s++;
len--;
}
- else if (len >= 2 && s[0] == '0' && (s[1] == 'x' || s[1] == 'X')) {
+ else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'x'))) {
s+=2;
len-=2;
}
return grok_number_flags(pv, len, valuep, 0);
}
+/*
+=for apidoc grok_infnan
+
+Helper for grok_number(), accepts various ways of spelling "infinity"
+or "not a number", and returns one of the following flag combinations:
+
+ IS_NUMBER_INFINITE
+ IS_NUMBER_NAN
+ IS_NUMBER_INFINITE | IS_NUMBER_NEG
+ IS_NUMBER_NAN | IS_NUMBER_NEG
+ 0
+
+If an infinity or not-a-number is recognized, the *sp will point to
+one past the end of the recognized string. If the recognition fails,
+zero is returned, and the *sp will not move.
+
+=cut
+*/
+
+int
+Perl_grok_infnan(const char** sp, const char* send)
+{
+ const char* s = *sp;
+ int flags = 0;
+
+ PERL_ARGS_ASSERT_GROK_INFNAN;
+
+ if (*s == '+') {
+ s++; if (s == send) return 0;
+ }
+ else if (*s == '-') {
+ flags |= IS_NUMBER_NEG; /* Yes, -NaN happens. Incorrect but happens. */
+ s++; if (s == send) return 0;
+ }
+
+ if (*s == '1') {
+ /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1#.IND (maybe also 1.#NAN) */
+ s++; if (s == send) return 0;
+ if (*s == '.') {
+ s++; if (s == send) return 0;
+ }
+ if (*s == '#') {
+ s++; if (s == send) return 0;
+ } else
+ return 0;
+ }
+
+ if (isALPHA_FOLD_EQ(*s, 'I')) {
+ /* INF or IND (1.#IND is indeterminate, a certain type of NAN) */
+ s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
+ s++; if (s == send) return 0;
+ if (isALPHA_FOLD_EQ(*s, 'F')) {
+ s++;
+ if (s < send && (isALPHA_FOLD_EQ(*s, 'I'))) {
+ s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
+ s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return 0;
+ s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return 0;
+ s++; if (s == send ||
+ /* allow either Infinity or Infinite */
+ !(isALPHA_FOLD_EQ(*s, 'Y') ||
+ isALPHA_FOLD_EQ(*s, 'E'))) return 0;
+ s++; if (s < send) return 0;
+ } else if (*s)
+ return 0;
+ flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
+ }
+ else if (isALPHA_FOLD_EQ(*s, 'D')) {
+ s++;
+ flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
+ } else
+ return 0;
+ }
+ else {
+ /* NAN */
+ if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) {
+ /* snan, qNaN */
+ /* XXX do something with the snan/qnan difference */
+ s++; if (s == send) return 0;
+ }
+
+ if (isALPHA_FOLD_EQ(*s, 'N')) {
+ s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return 0;
+ s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0;
+ s++;
+
+ flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
+
+ /* NaN can be followed by various stuff (NaNQ, NaNS), but
+ * there are also multiple different NaN values, and some
+ * implementations output the "payload" values,
+ * e.g. NaN123, NAN(abc), while some implementations just
+ * have weird stuff like NaN%. */
+ s = send;
+ }
+ else
+ return 0;
+ }
+
+ *sp = s;
+ return flags;
+}
+
static const UV uv_max_div_10 = UV_MAX / 10;
static const U8 uv_max_mod_10 = UV_MAX % 10;
{
const char *s = pv;
const char * const send = pv + len;
+ const char *d;
int numtype = 0;
- int sawinf = 0;
- int sawnan = 0;
PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS;
if (s == send)
return 0;
- /* next must be digit or the radix separator or beginning of infinity */
+ /* The first digit (after optional sign): note that might
+ * also point to "infinity" or "nan", or "1.#INF". */
+ d = s;
+
+ /* next must be digit or the radix separator or beginning of infinity/nan */
if (isDIGIT(*s)) {
/* UVs are at least 32 bits, so the first 9 decimal digits cannot
overflow. */
}
}
else
- return 0;
- } else if (*s == 'I' || *s == 'i') {
- s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
- s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
- s++; if (s < send && (*s == 'I' || *s == 'i')) {
- s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
- s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
- s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
- s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
- s++;
- }
- sawinf = 1;
- } else if (*s == 'N' || *s == 'n') {
- /* XXX TODO: There are signaling NaNs and quiet NaNs. */
- s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
- s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
- s++;
- sawnan = 1;
- } else
- return 0;
+ return 0;
+ }
- if (sawinf) {
- numtype &= IS_NUMBER_NEG; /* Keep track of sign */
- numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
- } else if (sawnan) {
- numtype &= IS_NUMBER_NEG; /* Keep track of sign */
- numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
- } else if (s < send) {
+ if (s < send) {
/* we can have an optional exponent part */
- if (*s == 'e' || *s == 'E') {
+ if (isALPHA_FOLD_EQ(*s, 'e')) {
s++;
if (s < send && (*s == '-' || *s == '+'))
s++;
*valuep = 0;
return IS_NUMBER_IN_UV;
}
+ /* We could be e.g. at "Inf" or "NaN", or at the "#" of "1.#INF". */
+ if ((s + 2 < send) && strchr("inqs#", toFOLD(*s))) {
+ /* Really detect inf/nan. Start at d, not s, since the above
+ * code might have already consumed the "1." or "1". */
+ int infnan = Perl_grok_infnan(&d, send);
+ if ((infnan & IS_NUMBER_INFINITY)) {
+ return (numtype | infnan); /* Keep sign for infinity. */
+ }
+ else if ((infnan & IS_NUMBER_NAN)) {
+ return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */
+ }
+ }
else if (flags & PERL_SCAN_TRAILING) {
return numtype | IS_NUMBER_TRAILING;
}
return val;
}
+#ifndef USE_QUADMATH
STATIC NV
S_mulexp10(NV value, I32 exponent)
{
}
return negative ? value / result : value * result;
}
+#endif /* #ifndef USE_QUADMATH */
NV
Perl_my_atof(pTHX_ const char* s)
{
NV x = 0.0;
-#ifdef USE_LOCALE_NUMERIC
+#ifdef USE_QUADMATH
+ Perl_my_atof2(aTHX_ s, &x);
+ return x;
+#else
+# ifdef USE_LOCALE_NUMERIC
PERL_ARGS_ASSERT_MY_ATOF;
{
Perl_atof2(s, x);
RESTORE_LC_NUMERIC();
}
-#else
+# else
Perl_atof2(s, x);
+# endif
#endif
return x;
}
+static char*
+S_my_atof_infnan(const char* s, bool negative, const char* send, NV* value)
+{
+ const char *p0 = negative ? s - 1 : s;
+ const char *p = p0;
+ int infnan = grok_infnan(&p, send);
+ if (infnan && p != p0) {
+ /* If we can generate inf/nan directly, let's do so. */
+#ifdef NV_INF
+ if ((infnan & IS_NUMBER_INFINITY)) {
+ *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF;
+ return (char*)p;
+ }
+#endif
+#ifdef NV_NAN
+ if ((infnan & IS_NUMBER_NAN)) {
+ *value = NV_NAN;
+ return (char*)p;
+ }
+#endif
+#ifdef Perl_strtod
+ /* If still here, we didn't have either NV_INF or NV_NAN,
+ * and can try falling back to native strtod/strtold.
+ *
+ * (Though, are our NV_INF or NV_NAN ever not defined?)
+ *
+ * The native interface might not recognize all the possible
+ * inf/nan strings Perl recognizes. What we can try
+ * is to try faking the input. We will try inf/-inf/nan
+ * as the most promising/portable input. */
+ {
+ const char* fake = NULL;
+ char* endp;
+ NV nv;
+ if ((infnan & IS_NUMBER_INFINITY)) {
+ fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf";
+ }
+ else if ((infnan & IS_NUMBER_NAN)) {
+ fake = "nan";
+ }
+ assert(fake);
+ nv = Perl_strtod(fake, &endp);
+ if (fake != endp) {
+ if ((infnan & IS_NUMBER_INFINITY)) {
+#ifdef Perl_isinf
+ if (Perl_isinf(nv))
+ *value = nv;
+#else
+ /* last resort, may generate SIGFPE */
+ *value = Perl_exp((NV)1e9);
+ if ((infnan & IS_NUMBER_NEG))
+ *value = -*value;
+#endif
+ return (char*)p; /* p, not endp */
+ }
+ else if ((infnan & IS_NUMBER_NAN)) {
+#ifdef Perl_isnan
+ if (Perl_isnan(nv))
+ *value = nv;
+#else
+ /* last resort, may generate SIGFPE */
+ *value = Perl_log((NV)-1.0);
+#endif
+ return (char*)p; /* p, not endp */
+ }
+ }
+ }
+#endif /* #ifdef Perl_strtod */
+ }
+ return NULL;
+}
+
char*
Perl_my_atof2(pTHX_ const char* orig, NV* value)
{
- NV result[3] = {0.0, 0.0, 0.0};
const char* s = orig;
-#ifdef USE_PERL_ATOF
- UV accumulator[2] = {0,0}; /* before/after dp */
+ NV result[3] = {0.0, 0.0, 0.0};
+#if defined(USE_PERL_ATOF) || defined(USE_QUADMATH)
+ const char* send = s + strlen(orig); /* one past the last */
bool negative = 0;
- const char* send = s + strlen(orig) - 1;
+#endif
+#if defined(USE_PERL_ATOF) && !defined(USE_QUADMATH)
+ UV accumulator[2] = {0,0}; /* before/after dp */
bool seen_digit = 0;
I32 exp_adjust[2] = {0,0};
I32 exp_acc[2] = {-1, -1};
I32 digit = 0;
I32 old_digit = 0;
I32 sig_digits = 0; /* noof significant digits seen so far */
+#endif
+#if defined(USE_PERL_ATOF) || defined(USE_QUADMATH)
PERL_ARGS_ASSERT_MY_ATOF2;
+ /* leading whitespace */
+ while (isSPACE(*s))
+ ++s;
+
+ /* sign */
+ switch (*s) {
+ case '-':
+ negative = 1;
+ /* FALLTHROUGH */
+ case '+':
+ ++s;
+ }
+#endif
+
+#ifdef USE_QUADMATH
+ {
+ char* endp;
+ if ((endp = S_my_atof_infnan(s, negative, send, value)))
+ return endp;
+ result[2] = strtoflt128(s, &endp);
+ if (s != endp) {
+ *value = negative ? -result[2] : result[2];
+ return endp;
+ }
+ return NULL;
+ }
+#elif defined(USE_PERL_ATOF)
+
/* There is no point in processing more significant digits
* than the NV can hold. Note that NV_DIG is a lower-bound value,
* while we need an upper-bound value. We add 2 to account for this;
/* the max number we can accumulate in a UV, and still safely do 10*N+9 */
#define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10))
- /* leading whitespace */
- while (isSPACE(*s))
- ++s;
-
- /* sign */
- switch (*s) {
- case '-':
- negative = 1;
- /* FALLTHROUGH */
- case '+':
- ++s;
- }
-
- /* punt to strtod for NaN/Inf; if no support for it there, tough luck */
-
-#ifdef HAS_STRTOD
- if (*s == 'n' || *s == 'N' || *s == 'i' || *s == 'I') {
- const char *p = negative ? s - 1 : s;
- char *endp;
- NV rslt;
- rslt = strtod(p, &endp);
- if (endp != p) {
- *value = rslt;
- return (char *)endp;
- }
+ {
+ const char* endp;
+ if ((endp = S_my_atof_infnan(s, negative, send, value)))
+ return (char*)endp;
}
-#endif
/* we accumulate digits into an integer; when this becomes too
* large, we add the total to NV and start again */
result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1];
}
- if (seen_digit && (*s == 'e' || *s == 'E')) {
+ if (seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) {
bool expnegative = 0;
++s;
return (char *)s;
}
-#if ! defined(HAS_MODFL) && defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
+/*
+=for apidoc isinfnan
+
+Perl_isinfnan() is utility function that returns true if the NV
+argument is either an infinity or a NaN, false otherwise. To test
+in more detail, use Perl_isinf() and Perl_isnan().
+
+This is also the logical inverse of Perl_isfinite().
+
+=cut
+*/
+bool
+Perl_isinfnan(NV nv)
+{
+#ifdef Perl_isinf
+ if (Perl_isinf(nv))
+ return TRUE;
+#endif
+#ifdef Perl_isnan
+ if (Perl_isnan(nv))
+ return TRUE;
+#endif
+ return FALSE;
+}
+
+#ifndef HAS_MODFL
+/* C99 has truncl, pre-C99 Solaris had aintl. We can use either with
+ * copysignl to emulate modfl, which is in some platforms missing or
+ * broken. */
+# if defined(HAS_TRUNCL) && defined(HAS_COPYSIGNL)
long double
Perl_my_modfl(long double x, long double *ip)
{
- *ip = aintl(x);
- return (x == *ip ? copysignl(0.0L, x) : x - *ip);
+ *ip = truncl(x);
+ return (x == *ip ? copysignl(0.0L, x) : x - *ip);
}
+# elif defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
+long double
+Perl_my_modfl(long double x, long double *ip)
+{
+ *ip = aintl(x);
+ return (x == *ip ? copysignl(0.0L, x) : x - *ip);
+}
+# endif
#endif
+/* Similarly, with ilobl and scalbnl we can emulate frexpl. */
#if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
long double
Perl_my_frexpl(long double x, int *e) {
- *e = x == 0.0L ? 0 : ilogbl(x) + 1;
- return (scalbnl(x, -*e));
+ *e = x == 0.0L ? 0 : ilogbl(x) + 1;
+ return (scalbnl(x, -*e));
}
#endif
If Configure detects this system has a signbit() that will work with
our NVs, then we just use it via the #define in perl.h. Otherwise,
-fall back on this implementation. As a first pass, this gets everything
-right except -0.0. Alas, catching -0.0 is the main use for this function,
-so this is not too helpful yet. Still, at least we have the scaffolding
-in place to support other systems, should that prove useful.
-
+fall back on this implementation. The main use of this function
+is catching -0.0.
Configure notes: This function is called 'Perl_signbit' instead of a
plain 'signbit' because it is easy to imagine a system having a signbit()
#if !defined(HAS_SIGNBIT)
int
Perl_signbit(NV x) {
+# ifdef Perl_fp_class_nzero
+ if (x == 0)
+ return Perl_fp_class_nzero(x);
+# endif
return (x < 0.0) ? 1 : 0;
}
#endif
o->op_ppaddr = PL_ppaddr[type]; \
} STMT_END
-STATIC SV*
-S_gv_ename(pTHX_ GV *gv)
-{
- SV* const tmpsv = sv_newmortal();
-
- PERL_ARGS_ASSERT_GV_ENAME;
-
- gv_efullname3(tmpsv, gv, NULL);
- return tmpsv;
-}
-
STATIC OP *
S_no_fh_allowed(pTHX_ OP *o)
{
}
STATIC OP *
-S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
-{
- PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
- yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)),
- SvUTF8(namesv) | flags);
- return o;
-}
-
-STATIC OP *
S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
{
PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
return o;
}
-STATIC OP *
-S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
-{
- PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
-
- yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
- SvUTF8(namesv) | flags);
- return o;
-}
-
STATIC void
S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
{
STATIC void
S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
{
- SV * const namesv = gv_ename(gv);
+ SV * const namesv = cv_name((CV *)gv, NULL);
PERL_ARGS_ASSERT_BAD_TYPE_GV;
yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
return;
type = o->op_type;
+
+ /* an op should only ever acquire op_private flags that we know about.
+ * If this fails, you may need to fix something in regen/op_private */
+ assert(!(o->op_private & ~PL_op_private_valid[type]));
+
if (o->op_private & OPpREFCOUNTED) {
switch (type) {
case OP_LEAVESUB:
SvREFCNT_inc_simple_void(gv);
#ifdef USE_ITHREADS
if (cPADOPo->op_padix > 0) {
- /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
- * may still exist on the pad */
pad_swipe(cPADOPo->op_padix, TRUE);
cPADOPo->op_padix = 0;
}
case OP_PUSHRE:
#ifdef USE_ITHREADS
if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
- /* No GvIN_PAD_off here, because other references may still
- * exist on the pad */
pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
}
#else
if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
- /* Both ENTERSUB and RV2CV use this bit, but for different pur-
- poses, so we need it clear. */
- o->op_private &= ~1;
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
else { /* Compile-time error message: */
OP *kid = cUNOPo->op_first;
CV *cv;
+ GV *gv;
if (kid->op_type != OP_PUSHMARK) {
if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
break;
}
- cv = GvCV(kGVOP_gv);
+ gv = kGVOP_gv;
+ cv = isGV(gv)
+ ? GvCV(gv)
+ : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
+ ? MUTABLE_CV(SvRV(gv))
+ : NULL;
if (!cv)
break;
if (CvLVALUE(cv))
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
o->op_flags |= OPf_SPECIAL;
- o->op_private &= ~1;
}
else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
SV * const oldwarnhook = PL_warnhook;
SV * const olddiehook = PL_diehook;
COP not_compiling;
+ U8 oldwarn = PL_dowarn;
dJMPENV;
PERL_ARGS_ASSERT_FOLD_CONSTANTS;
{
const char *s = SvPVX_const(sv);
while (s < SvEND(sv)) {
- if (*s == 'p' || *s == 'P') goto nope;
+ if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
s++;
}
}
PL_diehook = NULL;
JMPENV_PUSH(ret);
+ /* Effective $^W=1. */
+ if ( ! (PL_dowarn & G_WARN_ALL_MASK))
+ PL_dowarn |= G_WARN_ON;
+
switch (ret) {
case 0:
CALLRUNOPS(aTHX);
Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
}
JMPENV_POP;
+ PL_dowarn = oldwarn;
PL_warnhook = oldwarnhook;
PL_diehook = olddiehook;
PL_curcop = &PL_compiling;
NewOp(1101, padop, 1, PADOP);
padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
- padop->op_padix = pad_alloc(type, SVs_PADTMP);
+ padop->op_padix =
+ pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
PAD_SETSV(padop->op_padix, sv);
assert(sv);
PERL_ARGS_ASSERT_NEWGVOP;
#ifdef USE_ITHREADS
- GvIN_PAD_on(gv);
return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
#else
return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
PL_hints |= HINT_BLOCK_SCOPE;
PL_parser->copline = NOLINE;
- PL_parser->expect = XSTATE;
op_free(o);
}
PL_hints |= HINT_BLOCK_SCOPE;
PL_parser->copline = NOLINE;
- PL_parser->expect = XSTATE;
PL_cop_seqmax++; /* Purely for B::*'s benefit */
if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
PL_cop_seqmax++;
return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
}
+/* must not conflict with SVf_UTF8 */
+#define CV_CKPROTO_CURSTASH 0x1
+
void
Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
const STRLEN len, const U32 flags)
{
SV *name = NULL, *msg;
- const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
+ const char * cvp = SvROK(cv)
+ ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
+ ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
+ : ""
+ : CvPROTO(cv);
STRLEN clen = CvPROTOLEN(cv), plen = len;
PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
gv_efullname3(name = sv_newmortal(), gv, NULL);
else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
+ else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
+ name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
+ sv_catpvs(name, "::");
+ if (SvROK(gv)) {
+ assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
+ assert (CvNAMED(SvRV_const(gv)));
+ sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
+ }
+ else sv_catsv(name, (SV *)gv);
+ }
else name = (SV *)gv;
}
sv_setpvs(msg, "Prototype mismatch:");
{
if (!cv)
return NULL;
+ if (SvROK(cv)) return SvRV((SV *)cv);
assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
}
return NULL;
if (type == OP_CONST && cSVOPo->op_sv)
sv = cSVOPo->op_sv;
+ else if (type == OP_UNDEF && !o->op_private) {
+ sv = newSV(0);
+ SAVEFREESV(sv);
+ }
else if (cv && type == OP_CONST) {
sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
if (!sv)
if (CvNAMED(*spot))
hek = CvNAME_HEK(*spot);
else {
+ dVAR;
+ U32 hash;
+ PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
CvNAME_HEK_set(*spot, hek =
share_hek(
PadnamePV(name)+1,
- PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
+ PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash
)
);
+ CvLEXICAL_on(*spot);
}
if (mg) {
assert(mg->mg_obj);
*spot = cv;
}
setname:
+ CvLEXICAL_on(cv);
if (!CvNAME_HEK(cv)) {
- CvNAME_HEK_set(cv,
- hek
- ? share_hek_hek(hek)
- : share_hek(PadnamePV(name)+1,
+ if (hek) (void)share_hek_hek(hek);
+ else {
+ dVAR;
+ U32 hash;
+ PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
+ hek = share_hek(PadnamePV(name)+1,
PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
- 0)
- );
+ hash);
+ }
+ CvNAME_HEK_set(cv, hek);
}
if (const_sv) goto clone;
/* If the subroutine has no body, no attributes, and no builtin attributes
then it's just a sub declaration, and we may be able to get away with
storing with a placeholder scalar in the symbol table, rather than a
- full GV and CV. If anything is present then it will take a full CV to
+ full CV. If anything is present then it will take a full CV to
store it. */
const I32 gv_fetch_flags
= ec ? GV_NOADD_NOINIT :
bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
+ bool special = FALSE;
#endif
if (o_is_gv) {
o = NULL;
has_name = TRUE;
} else if (name) {
- gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
+ /* Try to optimise and avoid creating a GV. Instead, the CV’s name
+ hek and CvSTASH pointer together can imply the GV. If the name
+ contains a package name, then GvSTASH(CvGV(cv)) may differ from
+ CvSTASH, so forego the optimisation if we find any.
+ Also, we may be called from load_module at run time, so
+ PL_curstash (which sets CvSTASH) may not point to the stash the
+ sub is stored in. */
+ const I32 flags =
+ ec ? GV_NOADD_NOINIT
+ : PL_curstash != CopSTASH(PL_curcop)
+ || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
+ ? gv_fetch_flags
+ : GV_ADDMULTI | GV_NOINIT;
+ gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
has_name = TRUE;
} else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
SV * const sv = sv_newmortal();
has_name = FALSE;
}
if (!ec)
- move_proto_attr(&proto, &attrs, gv);
+ move_proto_attr(&proto, &attrs,
+ isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
if (proto) {
assert(proto->op_type == OP_CONST);
goto done;
}
- if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
- maximum a prototype before. */
+ if (!block && SvTYPE(gv) != SVt_PVGV) {
+ /* If we are not defining a new sub and the existing one is not a
+ full GV + CV... */
+ if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
+ /* We are applying attributes to an existing sub, so we need it
+ upgraded if it is a constant. */
+ if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
+ gv_init_pvn(gv, PL_curstash, name, namlen,
+ SVf_UTF8 * name_is_utf8);
+ }
+ else { /* Maybe prototype now, and had at maximum
+ a prototype or const/sub ref before. */
if (SvTYPE(gv) > SVt_NULL) {
cv_ckproto_len_flags((const CV *)gv,
o ? (const GV *)cSVOPo->op_sv : NULL, ps,
ps_len, ps_utf8);
}
- if (ps) {
+ if (!SvROK(gv)) {
+ if (ps) {
sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
- }
- else
+ }
+ else
sv_setiv(MUTABLE_SV(gv), -1);
+ }
SvREFCNT_dec(PL_compcv);
cv = PL_compcv = NULL;
goto done;
+ }
}
- cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
+ cv = (!name || (isGV(gv) && GvCVGEN(gv)))
+ ? NULL
+ : isGV(gv)
+ ? GvCV(gv)
+ : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
+ ? (CV *)SvRV(gv)
+ : NULL;
+
if (!block || !ps || *ps || attrs
|| (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
else
const_sv = op_const_sv(block, NULL);
+ if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
+ assert (block);
+ cv_ckproto_len_flags((const CV *)gv,
+ o ? (const GV *)cSVOPo->op_sv : NULL, ps,
+ ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
+ if (SvROK(gv)) {
+ /* All the other code for sub redefinition warnings expects the
+ clobbered sub to be a CV. Instead of making all those code
+ paths more complex, just inline the RV version here. */
+ const line_t oldline = CopLINE(PL_curcop);
+ assert(IN_PERL_COMPILETIME);
+ if (PL_parser && PL_parser->copline != NOLINE)
+ /* This ensures that warnings are reported at the first
+ line of a redefinition, not the last. */
+ CopLINE_set(PL_curcop, PL_parser->copline);
+ /* protect against fatal warnings leaking compcv */
+ SAVEFREESV(PL_compcv);
+
+ if (ckWARN(WARN_REDEFINE)
+ || ( ckWARN_d(WARN_REDEFINE)
+ && ( !const_sv || SvRV(gv) == const_sv
+ || sv_cmp(SvRV(gv), const_sv) )))
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ "Constant subroutine %"SVf" redefined",
+ SVfARG(cSVOPo->op_sv));
+
+ SvREFCNT_inc_simple_void_NN(PL_compcv);
+ CopLINE_set(PL_curcop, oldline);
+ SvREFCNT_dec(SvRV(gv));
+ }
+ }
+
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
if (exists || SvPOK(cv))
cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
/* already defined (or promised)? */
- if (exists || GvASSUMECV(gv)) {
+ if (exists || (isGV(gv) && GvASSUMECV(gv))) {
if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
cv = NULL;
else {
CvISXSUB_on(cv);
}
else {
- GvCV_set(gv, NULL);
- cv = newCONSTSUB_flags(
- NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
- const_sv
- );
+ if (isGV(gv)) {
+ if (name) GvCV_set(gv, NULL);
+ cv = newCONSTSUB_flags(
+ NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
+ const_sv
+ );
+ }
+ else {
+ if (!SvROK(gv)) {
+ SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
+ prepare_SV_for_RV((SV *)gv);
+ SvOK_off((SV *)gv);
+ SvROK_on(gv);
+ }
+ SvRV_set(gv, const_sv);
+ }
}
op_free(block);
SvREFCNT_dec(PL_compcv);
CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
OP * const cvstart = CvSTART(cv);
- CvGV_set(cv,gv);
- assert(!CvCVGV_RC(cv));
- assert(CvGV(cv) == gv);
+ if (isGV(gv)) {
+ CvGV_set(cv,gv);
+ assert(!CvCVGV_RC(cv));
+ assert(CvGV(cv) == gv);
+ }
+ else {
+ dVAR;
+ U32 hash;
+ PERL_HASH(hash, name, namlen);
+ CvNAME_HEK_set(cv,
+ share_hek(name,
+ name_is_utf8
+ ? -(SSize_t)namlen
+ : (SSize_t)namlen,
+ hash));
+ }
SvPOK_off(cv);
- CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
+ CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
+ | CvNAMED(cv);
CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
CvPADLIST(cv) = CvPADLIST(PL_compcv);
}
else {
cv = PL_compcv;
- if (name) {
+ if (name && isGV(gv)) {
GvCV_set(gv, cv);
GvCVGEN(gv) = 0;
if (HvENAME_HEK(GvSTASH(gv)))
/* sub Foo::bar { (shift)+1 } */
gv_method_changed(gv);
}
+ else if (name) {
+ if (!SvROK(gv)) {
+ SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
+ prepare_SV_for_RV((SV *)gv);
+ SvOK_off((SV *)gv);
+ SvROK_on(gv);
+ }
+ SvRV_set(gv, (SV *)cv);
+ }
}
- if (!CvGV(cv)) {
- CvGV_set(cv, gv);
+ if (!CvHASGV(cv)) {
+ if (isGV(gv)) CvGV_set(cv, gv);
+ else {
+ dVAR;
+ U32 hash;
+ PERL_HASH(hash, name, namlen);
+ CvNAME_HEK_set(cv, share_hek(name,
+ name_is_utf8
+ ? -(SSize_t)namlen
+ : (SSize_t)namlen,
+ hash));
+ }
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
}
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
- HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+ HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
+ ? GvSTASH(CvGV(cv))
+ : PL_curstash;
if (!name) SAVEFREESV(cv);
apply_attrs(stash, MUTABLE_SV(cv), attrs);
if (!name) SvREFCNT_inc_simple_void_NN(cv);
if (block && has_name) {
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
- SV * const tmpstr = sv_newmortal();
+ SV * const tmpstr = cv_name(cv,NULL);
GV * const db_postponed = gv_fetchpvs("DB::postponed",
GV_ADDMULTI, SVt_PVHV);
HV *hv;
CopFILE(PL_curcop),
(long)PL_subline,
(long)CopLINE(PL_curcop));
- gv_efullname3(tmpstr, gv, NULL);
(void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
if (PL_parser && PL_parser->error_count)
clear_special_blocks(name, gv, cv);
else
- process_special_blocks(floor, name, gv, cv);
+#ifdef PERL_DEBUG_READONLY_OPS
+ special =
+#endif
+ process_special_blocks(floor, name, gv, cv);
}
}
LEAVE_SCOPE(floor);
#ifdef PERL_DEBUG_READONLY_OPS
/* Watch out for BEGIN blocks */
- if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
+ if (!special) Slab_to_ro(slab);
#endif
return cv;
}
|| (*name == 'U' && strEQ(name, "UNITCHECK"))
|| (*name == 'C' && strEQ(name, "CHECK"))
|| (*name == 'I' && strEQ(name, "INIT"))) {
+ if (!isGV(gv)) {
+ (void)CvGV(cv);
+ assert(isGV(gv));
+ }
GvCV_set(gv, NULL);
SvREFCNT_dec_NN(MUTABLE_SV(cv));
}
}
-STATIC void
+STATIC bool
S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
GV *const gv,
CV *const cv)
if (strEQ(name, "BEGIN")) {
const I32 oldscope = PL_scopestack_ix;
dSP;
+ (void)CvGV(cv);
if (floor) LEAVE_SCOPE(floor);
ENTER;
PUSHSTACKi(PERLSI_REQUIRE);
POPSTACK;
LEAVE;
+ return TRUE;
}
else
- return;
+ return FALSE;
} else {
if (*name == 'E') {
if strEQ(name, "END") {
DEBUG_x( dump_sub(gv) );
Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
} else
- return;
+ return FALSE;
} else if (*name == 'U') {
if (strEQ(name, "UNITCHECK")) {
/* It's never too late to run a unitcheck block */
Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
}
else
- return;
+ return FALSE;
} else if (*name == 'C') {
if (strEQ(name, "CHECK")) {
if (PL_main_start)
Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
}
else
- return;
+ return FALSE;
} else if (*name == 'I') {
if (strEQ(name, "INIT")) {
if (PL_main_start)
Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
}
else
- return;
+ return FALSE;
} else
- return;
+ return FALSE;
DEBUG_x( dump_sub(gv) );
+ (void)CvGV(cv);
GvCV_set(gv,0); /* cv has been hijacked */
+ return TRUE;
}
}
PERL_ARGS_ASSERT_CK_RVCONST;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
- if (o->op_type == OP_RV2CV)
- o->op_private &= ~1;
if (kid->op_type == OP_CONST) {
int iscv;
SV * const kidsv = kid->op_sv;
/* Is it a constant from cv_const_sv()? */
- if (SvROK(kidsv) && SvREADONLY(kidsv)) {
- SV * const rsv = SvRV(kidsv);
- const svtype type = SvTYPE(rsv);
- const char *badtype = NULL;
-
- switch (o->op_type) {
- case OP_RV2SV:
- if (type > SVt_PVMG)
- badtype = "a SCALAR";
- break;
- case OP_RV2AV:
- if (type != SVt_PVAV)
- badtype = "an ARRAY";
- break;
- case OP_RV2HV:
- if (type != SVt_PVHV)
- badtype = "a HASH";
- break;
- case OP_RV2CV:
- if (type != SVt_PVCV)
- badtype = "a CODE";
- break;
- }
- if (badtype)
- Perl_croak(aTHX_ "Constant is not %s reference", badtype);
+ if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
return o;
}
if (SvTYPE(kidsv) == SVt_PVAV) return o;
* or we get possible typo warnings. OPpCONST_ENTERED says
* whether the lexer already added THIS instance of this symbol.
*/
- iscv = (o->op_type == OP_RV2CV) * 2;
- do {
- gv = gv_fetchsv(kidsv,
- iscv | !(kid->op_private & OPpCONST_ENTERED),
+ iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
+ gv = gv_fetchsv(kidsv,
+ o->op_type == OP_RV2CV
+ && o->op_private & OPpMAY_RETURN_CONSTANT
+ ? GV_NOEXPAND
+ : iscv | !(kid->op_private & OPpCONST_ENTERED),
iscv
? SVt_PVCV
: o->op_type == OP_RV2SV
: o->op_type == OP_RV2HV
? SVt_PVHV
: SVt_PVGV);
- } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
if (gv) {
+ if (!isGV(gv)) {
+ assert(iscv);
+ assert(SvROK(gv));
+ if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
+ && SvTYPE(SvRV(gv)) != SVt_PVCV)
+ gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
+ }
kid->op_type = OP_GV;
SvREFCNT_dec(kid->op_sv);
#ifdef USE_ITHREADS
/* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
assert (sizeof(PADOP) <= sizeof(SVOP));
- kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
+ kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
- GvIN_PAD_on(gv);
PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
#else
kid->op_sv = SvREFCNT_inc_simple_NN(gv);
if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
SVOP * const kid = (SVOP*)cUNOPo->op_first;
-
- if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
- SV * const sv = kid->op_sv;
- U32 was_readonly = SvREADONLY(sv);
- char *s;
- STRLEN len;
+ HEK *hek;
+ U32 hash;
+ char *s;
+ STRLEN len;
+ if (kid->op_type == OP_CONST) {
+ SV * const sv = kid->op_sv;
+ U32 const was_readonly = SvREADONLY(sv);
+ if (kid->op_private & OPpCONST_BARE) {
+ dVAR;
const char *end;
if (was_readonly) {
}
SvEND_set(sv, end);
sv_catpvs(sv, ".pm");
+ PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
+ hek = share_hek(SvPVX(sv),
+ (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
+ hash);
+ sv_sethek(sv, hek);
+ unshare_hek(hek);
SvFLAGS(sv) |= was_readonly;
+ }
+ else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
+ s = SvPV(sv, len);
+ if (SvREFCNT(sv) > 1) {
+ kid->op_sv = newSVpvn_share(
+ s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
+ SvREFCNT_dec_NN(sv);
+ }
+ else {
+ dVAR;
+ if (was_readonly) SvREADONLY_off(sv);
+ PERL_HASH(hash, s, len);
+ hek = share_hek(s,
+ SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
+ hash);
+ sv_sethek(sv, hek);
+ unshare_hek(hek);
+ SvFLAGS(sv) |= was_readonly;
+ }
+ }
}
}
kid->op_next = kid;
o->op_flags |= OPf_SPECIAL;
}
+ else if (kid->op_type == OP_CONST
+ && kid->op_private & OPpCONST_BARE) {
+ char tmpbuf[256];
+ STRLEN len;
+ PADOFFSET off;
+ const char * const name = SvPV(kSVOP_sv, len);
+ *tmpbuf = '&';
+ assert (len < 256);
+ Copy(name, tmpbuf+1, len, char);
+ off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
+ if (off != NOT_IN_PAD) {
+ if (PAD_COMPNAME_FLAGS_isOUR(off)) {
+ SV * const fq =
+ newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
+ sv_catpvs(fq, "::");
+ sv_catsv(fq, kSVOP_sv);
+ SvREFCNT_dec_NN(kSVOP_sv);
+ kSVOP->op_sv = fq;
+ }
+ else {
+ OP * const padop = newOP(OP_PADCV, 0);
+ padop->op_targ = off;
+ cUNOPx(firstkid)->op_first = padop;
+ op_free(kid);
+ }
+ }
+ }
firstkid = OP_SIBLING(firstkid);
}
CV *cv;
GV *gv;
PERL_ARGS_ASSERT_RV2CV_OP_CV;
- if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
+ if (flags & ~RV2CVOPCV_FLAG_MASK)
Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
if (cvop->op_type != OP_RV2CV)
return NULL;
switch (rvop->op_type) {
case OP_GV: {
gv = cGVOPx_gv(rvop);
+ if (!isGV(gv)) {
+ if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
+ cv = MUTABLE_CV(SvRV(gv));
+ gv = NULL;
+ break;
+ }
+ if (flags & RV2CVOPCV_RETURN_STUB)
+ return (CV *)gv;
+ else return NULL;
+ }
cv = GvCVu(gv);
if (!cv) {
if (flags & RV2CVOPCV_MARK_EARLY)
}
if (SvTYPE((SV*)cv) != SVt_PVCV)
return NULL;
- if (flags & RV2CVOPCV_RETURN_NAME_GV) {
- if (!CvANON(cv) || !gv)
+ if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
+ if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
+ && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
gv = CvGV(cv);
return (CV*)gv;
} else {
OP* o3 = aop;
if (proto >= proto_end)
- return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
+ {
+ SV * const namesv = cv_name((CV *)namegv, NULL);
+ yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
+ SVfARG(namesv)), SvUTF8(namesv));
+ return entersubop;
+ }
switch (*proto) {
case ';':
goto wrapref; /* autoconvert GLOB -> GLOBref */
else if (o3->op_type == OP_CONST)
o3->op_private &= ~OPpCONST_STRICT;
- else if (o3->op_type == OP_ENTERSUB) {
- /* accidental subroutine, revert to bareword */
- OP *gvop = ((UNOP*)o3)->op_first;
- if (gvop && gvop->op_type == OP_NULL) {
- gvop = ((UNOP*)gvop)->op_first;
- if (gvop) {
- 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);
- SV * const n = newSVpvs("");
- gv_fullname4(n, gv, "", FALSE);
- /* 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;
- }
- }
- }
- }
scalar(aop);
break;
case '+':
continue;
default:
oops: {
- SV* const tmpsv = sv_newmortal();
- gv_efullname3(tmpsv, namegv, NULL);
Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
- SVfARG(tmpsv), SVfARG(protosv));
+ SVfARG(cv_name((CV *)namegv, NULL)),
+ SVfARG(protosv));
}
}
}
if (!optional && proto_end > proto &&
(*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
- return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
+ {
+ SV * const namesv = cv_name((CV *)namegv, NULL);
+ yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
+ SVfARG(namesv)), SvUTF8(namesv));
+ }
return entersubop;
}
=cut
*/
-void
-Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
+static void
+S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
+ U8 *flagsp)
{
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);
*ckobj_p = callmg->mg_obj;
+ if (flagsp) *flagsp = callmg->mg_flags;
} else {
*ckfun_p = Perl_ck_entersub_args_proto_or_list;
*ckobj_p = (SV*)cv;
+ if (flagsp) *flagsp = 0;
}
}
+void
+Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
+{
+ PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
+ PERL_UNUSED_CONTEXT;
+ S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
+}
+
/*
-=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
+=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
Sets the function that will be used to fix up a call to I<cv>.
Specifically, the function is applied to an C<entersub> op tree for a
entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
In this call, I<entersubop> is a pointer to the C<entersub> op,
-which may be replaced by the check function, and I<namegv> is a GV
-supplying the name that should be used by the check function to refer
+which may be replaced by the check function, and I<namegv> supplies
+the name that should be used by the check function to refer
to the callee of the C<entersub> op if it needs to emit any diagnostics.
It is permitted to apply the check function in non-standard situations,
such as to a call to a different subroutine or to a method call.
+I<namegv> may not actually be a GV. For efficiency, perl may pass a
+CV or other SV instead. Whatever is passed can be used as the first
+argument to L</cv_name>. You can force perl to pass a GV by including
+C<CALL_CHECKER_REQUIRE_GV> in the I<flags>.
+
The current setting for a particular CV can be retrieved by
L</cv_get_call_checker>.
+=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
+
+The original form of L</cv_set_call_checker_flags>, which passes it the
+C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
+
=cut
*/
Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
{
PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
+ cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
+}
+
+void
+Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
+ SV *ckobj, U32 flags)
+{
+ PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
if (SvMAGICAL((SV*)cv))
mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
SvREFCNT_inc_simple_void_NN(ckobj);
callmg->mg_flags |= MGf_REFCOUNTED;
}
- callmg->mg_flags |= MGf_COPY;
+ callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
+ | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
}
}
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;
+ namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
o->op_private &= ~1;
o->op_private |= OPpENTERSUB_HASTARG;
} else {
Perl_call_checker ckfun;
SV *ckobj;
- cv_get_call_checker(cv, &ckfun, &ckobj);
- if (!namegv) { /* expletive! */
- /* XXX The call checker API is public. And it guarantees that
- a GV will be provided with the right name. So we have
- to create a GV. But it is still not correct, as its
- stringification will include the package. What we
- really need is a new call checker API that accepts a
- GV or string (or GV or CV). */
- HEK * const hek = CvNAME_HEK(cv);
+ U8 flags;
+ S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
+ if (!namegv) {
+ /* The original call checker API guarantees that a GV will be
+ be provided with the right name. So, if the old API was
+ used (or the REQUIRE_GV flag was passed), we have to reify
+ the CV’s GV, unless this is an anonymous sub. This is not
+ ideal for lexical subs, as its stringification will include
+ the package. But it is the best we can do. */
+ if (flags & MGf_REQUIRE_GV) {
+ if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
+ namegv = CvGV(cv);
+ }
+ else namegv = MUTABLE_GV(cv);
/* After a syntax error in a lexical sub, the cv that
rv2cv_op_cv returns may be a nameless stub. */
- if (!hek) return ck_entersub_args_list(o);;
- namegv = (GV *)sv_newmortal();
- gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
- SVf_UTF8 * !!HEK_UTF8(hek));
+ if (!namegv) return ck_entersub_args_list(o);
+
}
return ckfun(aTHX_ o, namegv, ckobj);
}
OP *rv2av, *q;
p = o->op_next;
if ( p->op_type == OP_GV
- && (gv = cGVOPx_gv(p))
+ && (gv = cGVOPx_gv(p)) && isGV(gv)
&& GvNAMELEN_get(gv) == 1
&& *GvNAME_get(gv) == '_'
&& GvSTASH(gv) == PL_defstash
: G_SCALAR) \
: dowantarray())
-/* Lower bits of op_private often carry the number of arguments, as
- * set by newBINOP, newUNOP and ck_fun */
-/* NOTE: OP_NEXTSTATE and OP_DBSTATE (i.e. COPs) carry NATIVE_HINTS
- * in op_private */
+/* NOTE: OPp* flags are now auto-generated and defined in opcode.h,
+ * from data in regen/op_private */
-/* Private for lvalues */
-#define OPpLVAL_INTRO 128 /* Lvalue must be localized or lvalue sub */
-/* Private for OPs with TARGLEX */
- /* (lower bits may carry MAXARG) */
-#define OPpTARGET_MY 16 /* Target is PADMY. */
-
-/* Private for OP_LEAVE, OP_LEAVESUB, OP_LEAVESUBLV and OP_LEAVEWRITE */
-#define OPpREFCOUNTED 64 /* op_targ carries a refcount */
-
-/* Private for OP_LEAVE and OP_LEAVELOOP */
-#define OPpLVALUE 128 /* Do not copy return value */
-
-/* Private for OP_AASSIGN */
-#define OPpASSIGN_COMMON 64 /* Left & right have syms in common. */
-
-/* Private for OP_SASSIGN */
-#define OPpASSIGN_BACKWARDS 64 /* Left & right switched. */
-#define OPpASSIGN_CV_TO_GV 128 /* Possible optimisation for constants. */
-
-/* Private for OP_MATCH and OP_SUBST{,CONT} */
-#define OPpRUNTIME 64 /* Pattern coming in on the stack */
-
-/* Private for OP_TRANS */
-#define OPpTRANS_FROM_UTF 1
-#define OPpTRANS_TO_UTF 2
-#define OPpTRANS_IDENTICAL 4 /* right side is same as left */
-#define OPpTRANS_SQUASH 8
- /* 16 is used for OPpTARGET_MY */
-#define OPpTRANS_COMPLEMENT 32
-#define OPpTRANS_GROWS 64
-#define OPpTRANS_DELETE 128
#define OPpTRANS_ALL (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE)
-/* Private for OP_REPEAT */
-#define OPpREPEAT_DOLIST 64 /* List replication. */
-
-/* Private for OP_RV2GV, OP_RV2SV, OP_AELEM, OP_HELEM, OP_PADSV */
-#define OPpDEREF (32|64) /* autovivify: Want ref to something: */
-#define OPpDEREF_AV 32 /* Want ref to AV. */
-#define OPpDEREF_HV 64 /* Want ref to HV. */
-#define OPpDEREF_SV (32|64) /* Want ref to SV. */
-
-/* OP_ENTERSUB and OP_RV2CV flags
-
-Flags are set on entersub and rv2cv in three phases:
- parser - the parser passes the flag to the op constructor
- check - the check routine called by the op constructor sets the flag
- context - application of scalar/ref/lvalue context applies the flag
-
-In the third stage, an entersub op might turn into an rv2cv op (undef &foo,
-\&foo, lock &foo, exists &foo, defined &foo). The two places where that
-happens (op_lvalue_flags and doref in op.c) need to make sure the flags do
-not conflict. Flags applied in the context phase are only set when there
-is no conversion of op type.
-
- bit entersub flag phase rv2cv flag phase
- --- ------------- ----- ---------- -----
- 1 OPpENTERSUB_INARGS context OPpMAY_RETURN_CONSTANT context
- 2 HINT_STRICT_REFS check HINT_STRICT_REFS check
- 4 OPpENTERSUB_HASTARG check
- 8 OPpENTERSUB_AMPER parser
- 16 OPpENTERSUB_DB check
- 32 OPpDEREF_AV context
- 64 OPpDEREF_HV context
- 128 OPpLVAL_INTRO context OPpENTERSUB_NOPAREN parser
-*/
- /* OP_ENTERSUB only */
-#define OPpENTERSUB_DB 16 /* Debug subroutine. */
-#define OPpENTERSUB_HASTARG 4 /* Called from OP tree. */
-#define OPpENTERSUB_INARGS 1 /* Lval used as arg to a sub. */
-/* used by OPpDEREF (32|64) */
-/* used by HINT_STRICT_REFS 2 */
- /* Mask for OP_ENTERSUB flags, the absence of which must be propagated
- in dynamic context */
+/* Mask for OP_ENTERSUB flags, the absence of which must be propagated
+ in dynamic context */
#define OPpENTERSUB_LVAL_MASK (OPpLVAL_INTRO|OPpENTERSUB_INARGS)
- /* OP_RV2CV only */
-#define OPpENTERSUB_AMPER 8 /* Used & form to call. */
-#define OPpENTERSUB_NOPAREN 128 /* bare sub call (without parens) */
-#define OPpMAY_RETURN_CONSTANT 1 /* If a constant sub, return the constant */
-
- /* OP_GV only */
-#define OPpEARLY_CV 32 /* foo() called before sub foo was parsed */
- /* OP_?ELEM only */
-#define OPpLVAL_DEFER 16 /* Defer creation of array/hash elem */
- /* OP_RV2[AH]V OP_[AH]SLICE */
-#define OPpSLICEWARNING 4 /* warn about @hash{$scalar} */
- /* OP_RV2[SAH]V, OP_GVSV, OP_ENTERITER only */
-#define OPpOUR_INTRO 16 /* Variable was in an our() */
- /* OP_RV2[AGH]V, OP_PAD[AH]V, OP_[AH]ELEM, OP_[AH]SLICE OP_AV2ARYLEN,
- OP_R?KEYS, OP_SUBSTR, OP_POS, OP_VEC */
-#define OPpMAYBE_LVSUB 8 /* We might be an lvalue to return */
- /* OP_RV2HV and OP_PADHV */
-#define OPpTRUEBOOL 32 /* %hash in (%hash || $foo) in
- void context */
-#define OPpMAYBE_TRUEBOOL 64 /* %hash in (%hash || $foo) where
- cx is not known till run time */
-
- /* OP_SUBSTR only */
-#define OPpSUBSTR_REPL_FIRST 16 /* 1st arg is replacement string */
-
- /* OP_PADSV only */
-#define OPpPAD_STATE 16 /* is a "state" pad */
- /* for OP_RV2?V, lower bits carry hints (currently only HINT_STRICT_REFS) */
-
- /* OP_PADRANGE only */
- /* bit 7 is OPpLVAL_INTRO */
-#define OPpPADRANGE_COUNTMASK 127 /* bits 6..0 hold target range, */
-#define OPpPADRANGE_COUNTSHIFT 7 /* 7 bits in total */
-
- /* OP_RV2GV only */
-#define OPpDONT_INIT_GV 4 /* Call gv_fetchpv with GV_NOINIT */
-/* (Therefore will return whatever is currently in the symbol table, not
- guaranteed to be a PVGV) */
-#define OPpALLOW_FAKE 16 /* OK to return fake glob */
-
-/* Private for OP_ENTERITER and OP_ITER */
-#define OPpITER_REVERSED 4 /* for (reverse ...) */
-#define OPpITER_DEF 8 /* for $_ or for my $_ */
-
-/* Private for OP_CONST */
-#define OPpCONST_NOVER 2 /* no 6; */
-#define OPpCONST_SHORTCIRCUIT 4 /* eg the constant 5 in (5 || foo) */
-#define OPpCONST_STRICT 8 /* bareword subject to strict 'subs' */
-#define OPpCONST_ENTERED 16 /* Has been entered as symbol. */
-#define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */
-
-/* Private for OP_FLIP/FLOP */
-#define OPpFLIP_LINENUM 64 /* Range arg potentially a line num. */
-
-/* Private for OP_LIST */
-#define OPpLIST_GUESSED 64 /* Guessed that pushmark was needed. */
-
-/* Private for OP_DELETE */
-#define OPpSLICE 64 /* Operating on a list of keys */
-/* Also OPpLVAL_INTRO (128) */
-
-/* Private for OP_EXISTS */
-#define OPpEXISTS_SUB 64 /* Checking for &sub, not {} or []. */
-
-/* Private for OP_SORT */
-#define OPpSORT_NUMERIC 1 /* Optimized away { $a <=> $b } */
-#define OPpSORT_INTEGER 2 /* Ditto while under "use integer" */
-#define OPpSORT_REVERSE 4 /* Reversed sort */
-#define OPpSORT_INPLACE 8 /* sort in-place; eg @a = sort @a */
-#define OPpSORT_DESCEND 16 /* Descending sort */
-#define OPpSORT_QSORT 32 /* Use quicksort (not mergesort) */
-#define OPpSORT_STABLE 64 /* Use a stable algorithm */
-
-/* Private for OP_REVERSE */
-#define OPpREVERSE_INPLACE 8 /* reverse in-place (@a = reverse @a) */
-
-/* Private for OP_OPEN and OP_BACKTICK */
-#define OPpOPEN_IN_RAW 16 /* binmode(F,":raw") on input fh */
-#define OPpOPEN_IN_CRLF 32 /* binmode(F,":crlf") on input fh */
-#define OPpOPEN_OUT_RAW 64 /* binmode(F,":raw") on output fh */
-#define OPpOPEN_OUT_CRLF 128 /* binmode(F,":crlf") on output fh */
-
-/* Private for COPs */
-#define OPpHUSH_VMSISH 32 /* hush DCL exit msg vmsish mode*/
-/* Note: Used for NATIVE_HINTS (shifted from the values in PL_hints),
- currently defined by vms/vmsish.h:
- 64
- 128
- */
+/* VMS-specific hints in COPs */
+#define OPpHINT_M_VMSISH_MASK (OPpHINT_M_VMSISH_STATUS|OPpHINT_M_VMSISH_TIME)
+
-/* Private for OP_FTXXX */
-#define OPpFT_ACCESS 2 /* use filetest 'access' */
-#define OPpFT_STACKED 4 /* stacked filetest, as "-f" in "-f -x $f" */
-#define OPpFT_STACKING 8 /* stacking filetest, as "-x" in "-f -x $f" */
-#define OPpFT_AFTER_t 16 /* previous op was -t */
-
-/* Private for OP_(MAP|GREP)(WHILE|START) */
-#define OPpGREP_LEX 2 /* iterate over lexical $_ */
-
-/* Private for OP_ENTEREVAL */
-#define OPpEVAL_HAS_HH 2 /* Does it have a copy of %^H */
-#define OPpEVAL_UNICODE 4
-#define OPpEVAL_BYTES 8
-#define OPpEVAL_COPHH 16 /* Construct %^H from cop hints */
-#define OPpEVAL_RE_REPARSING 32 /* eval_sv(..., G_RE_REPARSING) */
-
-/* Private for OP_CALLER, OP_WANTARRAY and OP_RUNCV */
-#define OPpOFFBYONE 128 /* Treat caller(1) as caller(2) */
-
-/* Private for OP_COREARGS */
-/* These must not conflict with OPpDONT_INIT_GV or OPpALLOW_FAKE.
- See pp.c:S_rv2gv. */
-#define OPpCOREARGS_DEREF1 1 /* Arg 1 is a handle constructor */
-#define OPpCOREARGS_DEREF2 2 /* Arg 2 is a handle constructor */
-#define OPpCOREARGS_SCALARMOD 64 /* \$ rather than \[$@%*] */
-#define OPpCOREARGS_PUSHMARK 128 /* Call pp_pushmark */
-
-/* Private for OP_(LAST|REDO|NEXT|GOTO|DUMP) */
-#define OPpPV_IS_UTF8 128 /* label is in UTF8 */
-
-/* Private for OP_SPLIT */
-#define OPpSPLIT_IMPLIM 128 /* implicit limit */
struct op {
BASEOP
#ifdef USE_ITHREADS
# define cGVOPx_gv(o) ((GV*)PAD_SVl(cPADOPx(o)->op_padix))
-# define IS_PADGV(v) (v && SvTYPE(v) == SVt_PVGV && isGV_with_GP(v) \
- && GvIN_PAD(v))
-# define IS_PADCONST(v) \
+# ifndef PERL_CORE
+# define IS_PADGV(v) (v && isGV(v))
+# define IS_PADCONST(v) \
(v && (SvREADONLY(v) || (SvIsCOW(v) && !SvLEN(v))))
+# endif
# define cSVOPx_sv(v) (cSVOPx(v)->op_sv \
? cSVOPx(v)->op_sv : PAD_SVl((v)->op_targ))
# define cSVOPx_svp(v) (cSVOPx(v)->op_sv \
? &cSVOPx(v)->op_sv : &PAD_SVl((v)->op_targ))
#else
# define cGVOPx_gv(o) ((GV*)cSVOPx(o)->op_sv)
-# define IS_PADGV(v) FALSE
-# define IS_PADCONST(v) FALSE
+# ifndef PERL_CORE
+# define IS_PADGV(v) FALSE
+# define IS_PADCONST(v) FALSE
+# endif
# define cSVOPx_sv(v) (cSVOPx(v)->op_sv)
# define cSVOPx_svp(v) (&cSVOPx(v)->op_sv)
#endif
#define OA_DANGEROUS 64
#define OA_DEFGV 128
-/* The next 4 bits encode op class information */
+/* The next 4 bits (8..11) encode op class information */
#define OCSHIFT 8
#define OA_CLASS_MASK (15 << OCSHIFT)
#define OA_FILESTATOP (12 << OCSHIFT)
#define OA_LOOPEXOP (13 << OCSHIFT)
+/* Each remaining nybble of PL_opargs (i.e. bits 12..15, 16..19 etc)
+ * encode the type for each arg */
#define OASHIFT 12
-/* Remaining nybbles of PL_opargs */
#define OA_SCALAR 1
#define OA_LIST 2
#define OA_AVREF 3
/* flags used by Perl_load_module() */
#define PERL_LOADMOD_DENY 0x1 /* no Module */
#define PERL_LOADMOD_NOIMPORT 0x2 /* use Module () */
-#define PERL_LOADMOD_IMPORT_OPS 0x4 /* use Module (...) */
+#define PERL_LOADMOD_IMPORT_OPS 0x4 /* import arguments
+ are passed as a sin-
+ gle op tree, not a
+ list of SVs */
#if defined(PERL_IN_PERLY_C) || defined(PERL_IN_OP_C) || defined(PERL_IN_TOKE_C)
#define ref(o, type) doref(o, type, TRUE)
#define RV2CVOPCV_MARK_EARLY 0x00000001
#define RV2CVOPCV_RETURN_NAME_GV 0x00000002
+#define RV2CVOPCV_RETURN_STUB 0x00000004
+#ifdef PERL_CORE /* behaviour of this flag is subject to change: */
+# define RV2CVOPCV_MAYBE_NAME_GV 0x00000008
+#endif
+#define RV2CVOPCV_FLAG_MASK 0x0000000f /* all of the above */
#define op_lvalue(op,t) Perl_op_lvalue_flags(aTHX_ op,t,0)
END_EXTERN_C
+
+#define OPpARG1_MASK 0x01
+#define OPpCOREARGS_DEREF1 0x01
+#define OPpENTERSUB_INARGS 0x01
+#define OPpSORT_NUMERIC 0x01
+#define OPpTRANS_FROM_UTF 0x01
+#define OPpCONST_NOVER 0x02
+#define OPpCOREARGS_DEREF2 0x02
+#define OPpEVAL_HAS_HH 0x02
+#define OPpFT_ACCESS 0x02
+#define OPpGREP_LEX 0x02
+#define OPpHINT_STRICT_REFS 0x02
+#define OPpSORT_INTEGER 0x02
+#define OPpTRANS_TO_UTF 0x02
+#define OPpARG2_MASK 0x03
+#define OPpCONST_SHORTCIRCUIT 0x04
+#define OPpDONT_INIT_GV 0x04
+#define OPpENTERSUB_HASTARG 0x04
+#define OPpEVAL_UNICODE 0x04
+#define OPpFT_STACKED 0x04
+#define OPpITER_REVERSED 0x04
+#define OPpSLICEWARNING 0x04
+#define OPpSORT_REVERSE 0x04
+#define OPpTRANS_IDENTICAL 0x04
+#define OPpARG3_MASK 0x07
+#define OPpPADRANGE_COUNTSHIFT 0x07
+#define OPpCONST_STRICT 0x08
+#define OPpENTERSUB_AMPER 0x08
+#define OPpEVAL_BYTES 0x08
+#define OPpFT_STACKING 0x08
+#define OPpITER_DEF 0x08
+#define OPpMAYBE_LVSUB 0x08
+#define OPpREVERSE_INPLACE 0x08
+#define OPpSORT_INPLACE 0x08
+#define OPpTRANS_SQUASH 0x08
+#define OPpARG4_MASK 0x0f
+#define OPpALLOW_FAKE 0x10
+#define OPpCONST_ENTERED 0x10
+#define OPpENTERSUB_DB 0x10
+#define OPpEVAL_COPHH 0x10
+#define OPpFT_AFTER_t 0x10
+#define OPpLVAL_DEFER 0x10
+#define OPpOPEN_IN_RAW 0x10
+#define OPpOUR_INTRO 0x10
+#define OPpPAD_STATE 0x10
+#define OPpSORT_DESCEND 0x10
+#define OPpSUBSTR_REPL_FIRST 0x10
+#define OPpTARGET_MY 0x10
+#define OPpDEREF_AV 0x20
+#define OPpEARLY_CV 0x20
+#define OPpEVAL_RE_REPARSING 0x20
+#define OPpHUSH_VMSISH 0x20
+#define OPpOPEN_IN_CRLF 0x20
+#define OPpSORT_QSORT 0x20
+#define OPpTRANS_COMPLEMENT 0x20
+#define OPpTRUEBOOL 0x20
+#define OPpASSIGN_BACKWARDS 0x40
+#define OPpASSIGN_COMMON 0x40
+#define OPpCONST_BARE 0x40
+#define OPpCOREARGS_SCALARMOD 0x40
+#define OPpDEREF_HV 0x40
+#define OPpEXISTS_SUB 0x40
+#define OPpFLIP_LINENUM 0x40
+#define OPpHINT_M_VMSISH_STATUS 0x40
+#define OPpLIST_GUESSED 0x40
+#define OPpMAYBE_TRUEBOOL 0x40
+#define OPpMAY_RETURN_CONSTANT 0x40
+#define OPpOPEN_OUT_RAW 0x40
+#define OPpREFCOUNTED 0x40
+#define OPpREPEAT_DOLIST 0x40
+#define OPpRUNTIME 0x40
+#define OPpSLICE 0x40
+#define OPpSORT_STABLE 0x40
+#define OPpTRANS_GROWS 0x40
+#define OPpDEREF 0x60
+#define OPpDEREF_SV 0x60
+#define OPpPADRANGE_COUNTMASK 0x7f
+#define OPpASSIGN_CV_TO_GV 0x80
+#define OPpCOREARGS_PUSHMARK 0x80
+#define OPpENTERSUB_NOPAREN 0x80
+#define OPpHINT_M_VMSISH_TIME 0x80
+#define OPpLVALUE 0x80
+#define OPpLVAL_INTRO 0x80
+#define OPpOFFBYONE 0x80
+#define OPpOPEN_OUT_CRLF 0x80
+#define OPpPV_IS_UTF8 0x80
+#define OPpSPLIT_IMPLIM 0x80
+#define OPpTRANS_DELETE 0x80
+START_EXTERN_C
+
+#ifndef PERL_GLOBAL_STRUCT_INIT
+
+# ifndef DOINIT
+
+/* data about the flags in op_private */
+
+EXTCONST I16 PL_op_private_bitdef_ix[];
+EXTCONST U16 PL_op_private_bitdefs[];
+EXTCONST char PL_op_private_labels[];
+EXTCONST I16 PL_op_private_bitfields[];
+EXTCONST U8 PL_op_private_valid[];
+
+# else
+
+
+/* PL_op_private_labels[]: the short descriptions of private flags.
+ * All labels are concatenated into a single char array
+ * (separated by \0's) for compactness.
+ */
+
+EXTCONST char PL_op_private_labels[] = {
+ '$','M','O','D','\0',
+ '+','1','\0',
+ '-','\0',
+ '<','U','T','F','\0',
+ '>','U','T','F','\0',
+ 'A','M','P','E','R','\0',
+ 'B','A','R','E','\0',
+ 'B','K','W','A','R','D','\0',
+ 'B','O','O','L','\0',
+ 'B','O','O','L','?','\0',
+ 'B','Y','T','E','S','\0',
+ 'C','O','M','M','O','N','\0',
+ 'C','O','M','P','L','\0',
+ 'C','O','N','S','T','\0',
+ 'C','O','P','H','H','\0',
+ 'C','V','2','G','V','\0',
+ 'D','B','G','\0',
+ 'D','E','F','\0',
+ 'D','E','L','\0',
+ 'D','E','R','E','F','1','\0',
+ 'D','E','R','E','F','2','\0',
+ 'D','E','S','C','\0',
+ 'D','O','L','I','S','T','\0',
+ 'D','R','E','F','A','V','\0',
+ 'D','R','E','F','H','V','\0',
+ 'D','R','E','F','S','V','\0',
+ 'E','A','R','L','Y','C','V','\0',
+ 'E','N','T','E','R','E','D','\0',
+ 'F','A','K','E','\0',
+ 'F','T','A','C','C','E','S','S','\0',
+ 'F','T','A','F','T','E','R','t','\0',
+ 'F','T','S','T','A','C','K','E','D','\0',
+ 'F','T','S','T','A','C','K','I','N','G','\0',
+ 'G','R','E','P','L','E','X','\0',
+ 'G','R','O','W','S','\0',
+ 'G','U','E','S','S','E','D','\0',
+ 'H','A','S','_','H','H','\0',
+ 'H','U','S','H','\0',
+ 'I','D','E','N','T','\0',
+ 'I','M','P','L','I','M','\0',
+ 'I','N','A','R','G','S','\0',
+ 'I','N','B','I','N','\0',
+ 'I','N','C','R','\0',
+ 'I','N','P','L','A','C','E','\0',
+ 'I','N','T','\0',
+ 'L','I','N','E','N','U','M','\0',
+ 'L','V','\0',
+ 'L','V','D','E','F','E','R','\0',
+ 'L','V','I','N','T','R','O','\0',
+ 'L','V','S','U','B','\0',
+ 'M','A','R','K','\0',
+ 'N','O','(',')','\0',
+ 'N','O','I','N','I','T','\0',
+ 'N','O','V','E','R','\0',
+ 'N','U','M','\0',
+ 'O','U','R','I','N','T','R','\0',
+ 'O','U','T','B','I','N','\0',
+ 'O','U','T','C','R','\0',
+ 'Q','S','O','R','T','\0',
+ 'R','E','F','C','\0',
+ 'R','E','P','A','R','S','E','\0',
+ 'R','E','P','L','1','S','T','\0',
+ 'R','E','V','\0',
+ 'R','E','V','E','R','S','E','D','\0',
+ 'R','T','I','M','E','\0',
+ 'S','H','O','R','T','\0',
+ 'S','L','I','C','E','\0',
+ 'S','L','I','C','E','W','A','R','N','\0',
+ 'S','Q','U','A','S','H','\0',
+ 'S','T','A','B','L','E','\0',
+ 'S','T','A','T','E','\0',
+ 'S','T','R','I','C','T','\0',
+ 'S','U','B','\0',
+ 'T','A','R','G','\0',
+ 'T','A','R','G','M','Y','\0',
+ 'U','N','I','\0',
+ 'U','T','F','\0',
+ 'V','M','S','I','S','H','_','S','T','A','T','U','S','\0',
+ 'V','M','S','I','S','H','_','T','I','M','E','\0',
+
+};
+
+
+
+/* PL_op_private_bitfields[]: details about each bit field type.
+ * Each defintition consists of the following list of words:
+ * bitmin
+ * label (index into PL_op_private_labels[]; -1 if no label)
+ * repeat for each enum entry (if any):
+ * enum value
+ * enum label (index into PL_op_private_labels[])
+ * -1
+ */
+
+EXTCONST I16 PL_op_private_bitfields[] = {
+ 0, 8, -1,
+ 0, 8, -1,
+ 0, 8, -1,
+ 0, 8, -1,
+ 0, 8, -1,
+ 0, 8, -1,
+ 5, -1, 1, 124, 2, 131, 3, 138, -1,
+
+};
+
+
+/* PL_op_private_bitdef_ix[]: map an op number to a starting position
+ * in PL_op_private_bitdefs. If -1, the op has no bits defined */
+
+EXTCONST I16 PL_op_private_bitdef_ix[] = {
+ -1, /* null */
+ -1, /* stub */
+ 0, /* scalar */
+ 1, /* pushmark */
+ 3, /* wantarray */
+ 4, /* const */
+ 9, /* gvsv */
+ 11, /* gv */
+ 12, /* gelem */
+ 13, /* padsv */
+ 16, /* padav */
+ 20, /* padhv */
+ -1, /* padany */
+ 26, /* pushre */
+ 27, /* rv2gv */
+ 34, /* rv2sv */
+ 39, /* av2arylen */
+ 41, /* rv2cv */
+ -1, /* anoncode */
+ 48, /* prototype */
+ 49, /* refgen */
+ 50, /* srefgen */
+ 51, /* ref */
+ 52, /* bless */
+ 53, /* backtick */
+ 58, /* glob */
+ 59, /* readline */
+ -1, /* rcatline */
+ 60, /* regcmaybe */
+ 61, /* regcreset */
+ 62, /* regcomp */
+ 63, /* match */
+ 65, /* qr */
+ 66, /* subst */
+ 68, /* substcont */
+ 70, /* trans */
+ 78, /* transr */
+ 86, /* sassign */
+ 89, /* aassign */
+ 92, /* chop */
+ 93, /* schop */
+ 94, /* chomp */
+ 96, /* schomp */
+ 98, /* defined */
+ 99, /* undef */
+ 100, /* study */
+ 101, /* pos */
+ 104, /* preinc */
+ 105, /* i_preinc */
+ 106, /* predec */
+ 107, /* i_predec */
+ 108, /* postinc */
+ 109, /* i_postinc */
+ 111, /* postdec */
+ 112, /* i_postdec */
+ 114, /* pow */
+ 116, /* multiply */
+ 118, /* i_multiply */
+ 120, /* divide */
+ 122, /* i_divide */
+ 124, /* modulo */
+ 126, /* i_modulo */
+ 128, /* repeat */
+ 130, /* add */
+ 132, /* i_add */
+ 134, /* subtract */
+ 136, /* i_subtract */
+ 138, /* concat */
+ 140, /* stringify */
+ 142, /* left_shift */
+ 144, /* right_shift */
+ 146, /* lt */
+ 147, /* i_lt */
+ 148, /* gt */
+ 149, /* i_gt */
+ 150, /* le */
+ 151, /* i_le */
+ 152, /* ge */
+ 153, /* i_ge */
+ 154, /* eq */
+ 155, /* i_eq */
+ 156, /* ne */
+ 157, /* i_ne */
+ 158, /* ncmp */
+ 159, /* i_ncmp */
+ 160, /* slt */
+ 161, /* sgt */
+ 162, /* sle */
+ 163, /* sge */
+ 164, /* seq */
+ 165, /* sne */
+ 166, /* scmp */
+ 167, /* bit_and */
+ 168, /* bit_xor */
+ 169, /* bit_or */
+ 170, /* negate */
+ 171, /* i_negate */
+ 173, /* not */
+ 174, /* complement */
+ 175, /* smartmatch */
+ 176, /* atan2 */
+ 178, /* sin */
+ 180, /* cos */
+ 182, /* rand */
+ 184, /* srand */
+ 186, /* exp */
+ 188, /* log */
+ 190, /* sqrt */
+ 192, /* int */
+ 194, /* hex */
+ 196, /* oct */
+ 198, /* abs */
+ 200, /* length */
+ 202, /* substr */
+ 206, /* vec */
+ 209, /* index */
+ 211, /* rindex */
+ 213, /* sprintf */
+ 214, /* formline */
+ 215, /* ord */
+ 217, /* chr */
+ 219, /* crypt */
+ 221, /* ucfirst */
+ 222, /* lcfirst */
+ 223, /* uc */
+ 224, /* lc */
+ 225, /* quotemeta */
+ 226, /* rv2av */
+ 232, /* aelemfast */
+ 233, /* aelemfast_lex */
+ 234, /* aelem */
+ 239, /* aslice */
+ 242, /* kvaslice */
+ 243, /* aeach */
+ 244, /* akeys */
+ 245, /* avalues */
+ 246, /* each */
+ 247, /* values */
+ 248, /* keys */
+ 250, /* delete */
+ 253, /* exists */
+ 255, /* rv2hv */
+ 263, /* helem */
+ 268, /* hslice */
+ 271, /* kvhslice */
+ 272, /* unpack */
+ 273, /* pack */
+ 274, /* split */
+ 275, /* join */
+ 276, /* list */
+ 278, /* lslice */
+ 279, /* anonlist */
+ 280, /* anonhash */
+ 281, /* splice */
+ 282, /* push */
+ 284, /* pop */
+ 285, /* shift */
+ 286, /* unshift */
+ 288, /* sort */
+ 295, /* reverse */
+ 297, /* grepstart */
+ 298, /* grepwhile */
+ 300, /* mapstart */
+ 301, /* mapwhile */
+ 303, /* range */
+ 304, /* flip */
+ 306, /* flop */
+ 308, /* and */
+ 309, /* or */
+ 310, /* xor */
+ 311, /* dor */
+ 312, /* cond_expr */
+ 314, /* andassign */
+ 315, /* orassign */
+ 316, /* dorassign */
+ 317, /* method */
+ 318, /* entersub */
+ 325, /* leavesub */
+ 327, /* leavesublv */
+ 329, /* caller */
+ 331, /* warn */
+ 332, /* die */
+ 333, /* reset */
+ -1, /* lineseq */
+ 334, /* nextstate */
+ 337, /* dbstate */
+ -1, /* unstack */
+ -1, /* enter */
+ 340, /* leave */
+ -1, /* scope */
+ 342, /* enteriter */
+ 346, /* iter */
+ -1, /* enterloop */
+ 347, /* leaveloop */
+ -1, /* return */
+ 349, /* last */
+ 351, /* next */
+ 353, /* redo */
+ 355, /* dump */
+ 357, /* goto */
+ 359, /* exit */
+ -1, /* method_named */
+ 360, /* entergiven */
+ 361, /* leavegiven */
+ 362, /* enterwhen */
+ 363, /* leavewhen */
+ -1, /* break */
+ -1, /* continue */
+ 364, /* open */
+ 369, /* close */
+ 370, /* pipe_op */
+ 371, /* fileno */
+ 372, /* umask */
+ 373, /* binmode */
+ 374, /* tie */
+ 375, /* untie */
+ 376, /* tied */
+ 377, /* dbmopen */
+ 378, /* dbmclose */
+ 379, /* sselect */
+ 380, /* select */
+ 381, /* getc */
+ 382, /* read */
+ 383, /* enterwrite */
+ 384, /* leavewrite */
+ -1, /* prtf */
+ -1, /* print */
+ -1, /* say */
+ 386, /* sysopen */
+ 387, /* sysseek */
+ 388, /* sysread */
+ 389, /* syswrite */
+ 390, /* eof */
+ 391, /* tell */
+ 392, /* seek */
+ 393, /* truncate */
+ 394, /* fcntl */
+ 395, /* ioctl */
+ 396, /* flock */
+ 398, /* send */
+ 399, /* recv */
+ 400, /* socket */
+ 401, /* sockpair */
+ 402, /* bind */
+ 403, /* connect */
+ 404, /* listen */
+ 405, /* accept */
+ 406, /* shutdown */
+ 407, /* gsockopt */
+ 408, /* ssockopt */
+ 409, /* getsockname */
+ 410, /* getpeername */
+ 411, /* lstat */
+ 412, /* stat */
+ 413, /* ftrread */
+ 418, /* ftrwrite */
+ 423, /* ftrexec */
+ 428, /* fteread */
+ 433, /* ftewrite */
+ 438, /* fteexec */
+ 443, /* ftis */
+ 447, /* ftsize */
+ 451, /* ftmtime */
+ 455, /* ftatime */
+ 459, /* ftctime */
+ 463, /* ftrowned */
+ 467, /* fteowned */
+ 471, /* ftzero */
+ 475, /* ftsock */
+ 479, /* ftchr */
+ 483, /* ftblk */
+ 487, /* ftfile */
+ 491, /* ftdir */
+ 495, /* ftpipe */
+ 499, /* ftsuid */
+ 503, /* ftsgid */
+ 507, /* ftsvtx */
+ 511, /* ftlink */
+ 515, /* fttty */
+ 519, /* fttext */
+ 523, /* ftbinary */
+ 527, /* chdir */
+ 529, /* chown */
+ 531, /* chroot */
+ 533, /* unlink */
+ 535, /* chmod */
+ 537, /* utime */
+ 539, /* rename */
+ 541, /* link */
+ 543, /* symlink */
+ 545, /* readlink */
+ 546, /* mkdir */
+ 548, /* rmdir */
+ 550, /* open_dir */
+ 551, /* readdir */
+ 552, /* telldir */
+ 553, /* seekdir */
+ 554, /* rewinddir */
+ 555, /* closedir */
+ -1, /* fork */
+ 556, /* wait */
+ 557, /* waitpid */
+ 559, /* system */
+ 561, /* exec */
+ 563, /* kill */
+ 565, /* getppid */
+ 566, /* getpgrp */
+ 568, /* setpgrp */
+ 570, /* getpriority */
+ 572, /* setpriority */
+ 574, /* time */
+ -1, /* tms */
+ 575, /* localtime */
+ 576, /* gmtime */
+ 577, /* alarm */
+ 578, /* sleep */
+ 580, /* shmget */
+ 581, /* shmctl */
+ 582, /* shmread */
+ 583, /* shmwrite */
+ 584, /* msgget */
+ 585, /* msgctl */
+ 586, /* msgsnd */
+ 587, /* msgrcv */
+ 588, /* semop */
+ 589, /* semget */
+ 590, /* semctl */
+ 591, /* require */
+ 592, /* dofile */
+ -1, /* hintseval */
+ 593, /* entereval */
+ 599, /* leaveeval */
+ 601, /* entertry */
+ -1, /* leavetry */
+ 602, /* ghbyname */
+ 603, /* ghbyaddr */
+ -1, /* ghostent */
+ 604, /* gnbyname */
+ 605, /* gnbyaddr */
+ -1, /* gnetent */
+ 606, /* gpbyname */
+ 607, /* gpbynumber */
+ -1, /* gprotoent */
+ 608, /* gsbyname */
+ 609, /* gsbyport */
+ -1, /* gservent */
+ 610, /* shostent */
+ 611, /* snetent */
+ 612, /* sprotoent */
+ 613, /* sservent */
+ -1, /* ehostent */
+ -1, /* enetent */
+ -1, /* eprotoent */
+ -1, /* eservent */
+ 614, /* gpwnam */
+ 615, /* gpwuid */
+ -1, /* gpwent */
+ -1, /* spwent */
+ -1, /* epwent */
+ 616, /* ggrnam */
+ 617, /* ggrgid */
+ -1, /* ggrent */
+ -1, /* sgrent */
+ -1, /* egrent */
+ -1, /* getlogin */
+ 618, /* syscall */
+ 619, /* lock */
+ 620, /* once */
+ -1, /* custom */
+ 621, /* reach */
+ 622, /* rkeys */
+ 624, /* rvalues */
+ 625, /* coreargs */
+ 629, /* runcv */
+ 630, /* fc */
+ -1, /* padcv */
+ -1, /* introcv */
+ -1, /* clonecv */
+ 631, /* padrange */
+
+};
+
+
+
+/* PL_op_private_bitdefs[]: given a starting position in this array (as
+ * supplied by PL_op_private_bitdef_ix[]), each word (until a stop bit is
+ * seen) defines the meaning of a particular op_private bit for a
+ * particular op. Each word consists of:
+ * bit 0: stop bit: this is the last bit def for the current op
+ * bit 1: bitfield: if set, this defines a bit field rather than a flag
+ * bits 2..4: unsigned number in the range 0..7 which is the bit number
+ * bits 5..15: unsigned number in the range 0..2047 which is an index
+ * into PL_op_private_labels[] (for a flag), or
+ * into PL_op_private_bitfields[] (for a bit field)
+ */
+
+EXTCONST U16 PL_op_private_bitdefs[] = {
+ /* scalar */ 0x0003,
+ /* pushmark */ 0x25bc, 0x37b1,
+ /* wantarray */ 0x00bd,
+ /* const */ 0x0358, 0x1330, 0x386c, 0x3328, 0x2985,
+ /* gvsv */ 0x25bc, 0x2ad1,
+ /* gv */ 0x1235,
+ /* gelem */ 0x0067,
+ /* padsv */ 0x25bc, 0x025a, 0x37b1,
+ /* padav */ 0x25bc, 0x37b0, 0x26ac, 0x34a9,
+ /* padhv */ 0x25bc, 0x0578, 0x04d4, 0x37b0, 0x26ac, 0x34a9,
+ /* pushre */ 0x3279,
+ /* rv2gv */ 0x25bc, 0x025a, 0x1430, 0x26ac, 0x28a8, 0x3864, 0x0003,
+ /* rv2sv */ 0x25bc, 0x025a, 0x2ad0, 0x3864, 0x0003,
+ /* av2arylen */ 0x26ac, 0x0003,
+ /* rv2cv */ 0x281c, 0x0898, 0x0ad0, 0x028c, 0x39c8, 0x3864, 0x0003,
+ /* prototype */ 0x0003,
+ /* refgen */ 0x0003,
+ /* srefgen */ 0x0003,
+ /* ref */ 0x0003,
+ /* bless */ 0x012f,
+ /* backtick */ 0x2cbc, 0x2bd8, 0x2134, 0x2070, 0x0003,
+ /* glob */ 0x012f,
+ /* readline */ 0x0003,
+ /* regcmaybe */ 0x0003,
+ /* regcreset */ 0x0003,
+ /* regcomp */ 0x0003,
+ /* match */ 0x3278, 0x3a71,
+ /* qr */ 0x3279,
+ /* subst */ 0x3278, 0x3a71,
+ /* substcont */ 0x3278, 0x0003,
+ /* trans */ 0x0bdc, 0x1ab8, 0x07d4, 0x3a70, 0x35ec, 0x1de8, 0x01e4, 0x0141,
+ /* transr */ 0x0bdc, 0x1ab8, 0x07d4, 0x3a70, 0x35ec, 0x1de8, 0x01e4, 0x0141,
+ /* sassign */ 0x0a1c, 0x03f8, 0x0067,
+ /* aassign */ 0x06f8, 0x26ac, 0x0067,
+ /* chop */ 0x0003,
+ /* schop */ 0x0003,
+ /* chomp */ 0x3a70, 0x0003,
+ /* schomp */ 0x3a70, 0x0003,
+ /* defined */ 0x0003,
+ /* undef */ 0x0003,
+ /* study */ 0x0003,
+ /* pos */ 0x25bc, 0x26ac, 0x0003,
+ /* preinc */ 0x0003,
+ /* i_preinc */ 0x0003,
+ /* predec */ 0x0003,
+ /* i_predec */ 0x0003,
+ /* postinc */ 0x0003,
+ /* i_postinc */ 0x3a70, 0x0003,
+ /* postdec */ 0x0003,
+ /* i_postdec */ 0x3a70, 0x0003,
+ /* pow */ 0x3a70, 0x0067,
+ /* multiply */ 0x3a70, 0x0067,
+ /* i_multiply */ 0x3a70, 0x0067,
+ /* divide */ 0x3a70, 0x0067,
+ /* i_divide */ 0x3a70, 0x0067,
+ /* modulo */ 0x3a70, 0x0067,
+ /* i_modulo */ 0x3a70, 0x0067,
+ /* repeat */ 0x0eb8, 0x0067,
+ /* add */ 0x3a70, 0x0067,
+ /* i_add */ 0x3a70, 0x0067,
+ /* subtract */ 0x3a70, 0x0067,
+ /* i_subtract */ 0x3a70, 0x0067,
+ /* concat */ 0x3a70, 0x0067,
+ /* stringify */ 0x3a70, 0x012f,
+ /* left_shift */ 0x3a70, 0x0067,
+ /* right_shift */ 0x3a70, 0x0067,
+ /* lt */ 0x0067,
+ /* i_lt */ 0x0067,
+ /* gt */ 0x0067,
+ /* i_gt */ 0x0067,
+ /* le */ 0x0067,
+ /* i_le */ 0x0067,
+ /* ge */ 0x0067,
+ /* i_ge */ 0x0067,
+ /* eq */ 0x0067,
+ /* i_eq */ 0x0067,
+ /* ne */ 0x0067,
+ /* i_ne */ 0x0067,
+ /* ncmp */ 0x0067,
+ /* i_ncmp */ 0x0067,
+ /* slt */ 0x0067,
+ /* sgt */ 0x0067,
+ /* sle */ 0x0067,
+ /* sge */ 0x0067,
+ /* seq */ 0x0067,
+ /* sne */ 0x0067,
+ /* scmp */ 0x0067,
+ /* bit_and */ 0x0067,
+ /* bit_xor */ 0x0067,
+ /* bit_or */ 0x0067,
+ /* negate */ 0x0003,
+ /* i_negate */ 0x3a70, 0x0003,
+ /* not */ 0x0003,
+ /* complement */ 0x0003,
+ /* smartmatch */ 0x0067,
+ /* atan2 */ 0x3a70, 0x012f,
+ /* sin */ 0x3a70, 0x0003,
+ /* cos */ 0x3a70, 0x0003,
+ /* rand */ 0x3a70, 0x012f,
+ /* srand */ 0x3a70, 0x012f,
+ /* exp */ 0x3a70, 0x0003,
+ /* log */ 0x3a70, 0x0003,
+ /* sqrt */ 0x3a70, 0x0003,
+ /* int */ 0x3a70, 0x0003,
+ /* hex */ 0x3a70, 0x0003,
+ /* oct */ 0x3a70, 0x0003,
+ /* abs */ 0x3a70, 0x0003,
+ /* length */ 0x3a70, 0x0003,
+ /* substr */ 0x25bc, 0x2fd0, 0x26ac, 0x00cb,
+ /* vec */ 0x25bc, 0x26ac, 0x0067,
+ /* index */ 0x3a70, 0x012f,
+ /* rindex */ 0x3a70, 0x012f,
+ /* sprintf */ 0x012f,
+ /* formline */ 0x012f,
+ /* ord */ 0x3a70, 0x0003,
+ /* chr */ 0x3a70, 0x0003,
+ /* crypt */ 0x3a70, 0x012f,
+ /* ucfirst */ 0x0003,
+ /* lcfirst */ 0x0003,
+ /* uc */ 0x0003,
+ /* lc */ 0x0003,
+ /* quotemeta */ 0x0003,
+ /* rv2av */ 0x25bc, 0x2ad0, 0x26ac, 0x34a8, 0x3864, 0x0003,
+ /* aelemfast */ 0x01ff,
+ /* aelemfast_lex */ 0x01ff,
+ /* aelem */ 0x25bc, 0x025a, 0x24b0, 0x26ac, 0x0067,
+ /* aslice */ 0x25bc, 0x26ac, 0x34a9,
+ /* kvaslice */ 0x26ad,
+ /* aeach */ 0x0003,
+ /* akeys */ 0x0003,
+ /* avalues */ 0x0003,
+ /* each */ 0x0003,
+ /* values */ 0x0003,
+ /* keys */ 0x26ac, 0x0003,
+ /* delete */ 0x25bc, 0x33f8, 0x0003,
+ /* exists */ 0x3958, 0x0003,
+ /* rv2hv */ 0x25bc, 0x0578, 0x04d4, 0x2ad0, 0x26ac, 0x34a8, 0x3864, 0x0003,
+ /* helem */ 0x25bc, 0x025a, 0x24b0, 0x26ac, 0x0067,
+ /* hslice */ 0x25bc, 0x26ac, 0x34a9,
+ /* kvhslice */ 0x26ad,
+ /* unpack */ 0x012f,
+ /* pack */ 0x012f,
+ /* split */ 0x1ebd,
+ /* join */ 0x012f,
+ /* list */ 0x25bc, 0x1b79,
+ /* lslice */ 0x0067,
+ /* anonlist */ 0x012f,
+ /* anonhash */ 0x012f,
+ /* splice */ 0x012f,
+ /* push */ 0x3a70, 0x012f,
+ /* pop */ 0x0003,
+ /* shift */ 0x0003,
+ /* unshift */ 0x3a70, 0x012f,
+ /* sort */ 0x36d8, 0x2d74, 0x0e10, 0x21cc, 0x30c8, 0x22c4, 0x2a41,
+ /* reverse */ 0x21cc, 0x0003,
+ /* grepstart */ 0x19a5,
+ /* grepwhile */ 0x19a4, 0x0003,
+ /* mapstart */ 0x19a5,
+ /* mapwhile */ 0x19a4, 0x0003,
+ /* range */ 0x0003,
+ /* flip */ 0x2358, 0x0003,
+ /* flop */ 0x2358, 0x0003,
+ /* and */ 0x0003,
+ /* or */ 0x0003,
+ /* xor */ 0x0067,
+ /* dor */ 0x0003,
+ /* cond_expr */ 0x25bc, 0x0003,
+ /* andassign */ 0x0003,
+ /* orassign */ 0x0003,
+ /* dorassign */ 0x0003,
+ /* method */ 0x0003,
+ /* entersub */ 0x25bc, 0x025a, 0x0ad0, 0x028c, 0x39c8, 0x3864, 0x1f81,
+ /* leavesub */ 0x2e38, 0x0003,
+ /* leavesublv */ 0x2e38, 0x0003,
+ /* caller */ 0x00bc, 0x012f,
+ /* warn */ 0x012f,
+ /* die */ 0x012f,
+ /* reset */ 0x012f,
+ /* nextstate */ 0x3e1c, 0x3c58, 0x1d55,
+ /* dbstate */ 0x3e1c, 0x3c58, 0x1d55,
+ /* leave */ 0x245c, 0x2e39,
+ /* enteriter */ 0x25bc, 0x2ad0, 0x0b4c, 0x3149,
+ /* iter */ 0x3149,
+ /* leaveloop */ 0x245c, 0x0067,
+ /* last */ 0x3bdc, 0x0003,
+ /* next */ 0x3bdc, 0x0003,
+ /* redo */ 0x3bdc, 0x0003,
+ /* dump */ 0x3bdc, 0x0003,
+ /* goto */ 0x3bdc, 0x0003,
+ /* exit */ 0x012f,
+ /* entergiven */ 0x0003,
+ /* leavegiven */ 0x0003,
+ /* enterwhen */ 0x0003,
+ /* leavewhen */ 0x0003,
+ /* open */ 0x2cbc, 0x2bd8, 0x2134, 0x2070, 0x012f,
+ /* close */ 0x012f,
+ /* pipe_op */ 0x012f,
+ /* fileno */ 0x012f,
+ /* umask */ 0x012f,
+ /* binmode */ 0x012f,
+ /* tie */ 0x012f,
+ /* untie */ 0x0003,
+ /* tied */ 0x0003,
+ /* dbmopen */ 0x012f,
+ /* dbmclose */ 0x0003,
+ /* sselect */ 0x012f,
+ /* select */ 0x012f,
+ /* getc */ 0x012f,
+ /* read */ 0x012f,
+ /* enterwrite */ 0x012f,
+ /* leavewrite */ 0x2e38, 0x0003,
+ /* sysopen */ 0x012f,
+ /* sysseek */ 0x012f,
+ /* sysread */ 0x012f,
+ /* syswrite */ 0x012f,
+ /* eof */ 0x012f,
+ /* tell */ 0x012f,
+ /* seek */ 0x012f,
+ /* truncate */ 0x012f,
+ /* fcntl */ 0x012f,
+ /* ioctl */ 0x012f,
+ /* flock */ 0x3a70, 0x012f,
+ /* send */ 0x012f,
+ /* recv */ 0x012f,
+ /* socket */ 0x012f,
+ /* sockpair */ 0x012f,
+ /* bind */ 0x012f,
+ /* connect */ 0x012f,
+ /* listen */ 0x012f,
+ /* accept */ 0x012f,
+ /* shutdown */ 0x012f,
+ /* gsockopt */ 0x012f,
+ /* ssockopt */ 0x012f,
+ /* getsockname */ 0x0003,
+ /* getpeername */ 0x0003,
+ /* lstat */ 0x0003,
+ /* stat */ 0x0003,
+ /* ftrread */ 0x15f0, 0x184c, 0x1708, 0x14c4, 0x0003,
+ /* ftrwrite */ 0x15f0, 0x184c, 0x1708, 0x14c4, 0x0003,
+ /* ftrexec */ 0x15f0, 0x184c, 0x1708, 0x14c4, 0x0003,
+ /* fteread */ 0x15f0, 0x184c, 0x1708, 0x14c4, 0x0003,
+ /* ftewrite */ 0x15f0, 0x184c, 0x1708, 0x14c4, 0x0003,
+ /* fteexec */ 0x15f0, 0x184c, 0x1708, 0x14c4, 0x0003,
+ /* ftis */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftsize */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftmtime */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftatime */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftctime */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftrowned */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* fteowned */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftzero */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftsock */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftchr */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftblk */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftfile */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftdir */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftpipe */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftsuid */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftsgid */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftsvtx */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftlink */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* fttty */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* fttext */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* ftbinary */ 0x15f0, 0x184c, 0x1708, 0x0003,
+ /* chdir */ 0x3a70, 0x012f,
+ /* chown */ 0x3a70, 0x012f,
+ /* chroot */ 0x3a70, 0x0003,
+ /* unlink */ 0x3a70, 0x012f,
+ /* chmod */ 0x3a70, 0x012f,
+ /* utime */ 0x3a70, 0x012f,
+ /* rename */ 0x3a70, 0x012f,
+ /* link */ 0x3a70, 0x012f,
+ /* symlink */ 0x3a70, 0x012f,
+ /* readlink */ 0x0003,
+ /* mkdir */ 0x3a70, 0x012f,
+ /* rmdir */ 0x3a70, 0x0003,
+ /* open_dir */ 0x012f,
+ /* readdir */ 0x0003,
+ /* telldir */ 0x0003,
+ /* seekdir */ 0x012f,
+ /* rewinddir */ 0x0003,
+ /* closedir */ 0x0003,
+ /* wait */ 0x3a71,
+ /* waitpid */ 0x3a70, 0x012f,
+ /* system */ 0x3a70, 0x012f,
+ /* exec */ 0x3a70, 0x012f,
+ /* kill */ 0x3a70, 0x012f,
+ /* getppid */ 0x3a71,
+ /* getpgrp */ 0x3a70, 0x012f,
+ /* setpgrp */ 0x3a70, 0x012f,
+ /* getpriority */ 0x3a70, 0x012f,
+ /* setpriority */ 0x3a70, 0x012f,
+ /* time */ 0x3a71,
+ /* localtime */ 0x0003,
+ /* gmtime */ 0x012f,
+ /* alarm */ 0x0003,
+ /* sleep */ 0x3a70, 0x012f,
+ /* shmget */ 0x012f,
+ /* shmctl */ 0x012f,
+ /* shmread */ 0x012f,
+ /* shmwrite */ 0x012f,
+ /* msgget */ 0x012f,
+ /* msgctl */ 0x012f,
+ /* msgsnd */ 0x012f,
+ /* msgrcv */ 0x012f,
+ /* semop */ 0x012f,
+ /* semget */ 0x012f,
+ /* semctl */ 0x012f,
+ /* require */ 0x0003,
+ /* dofile */ 0x0003,
+ /* entereval */ 0x2ed4, 0x0950, 0x062c, 0x3b48, 0x1c64, 0x0003,
+ /* leaveeval */ 0x2e38, 0x0003,
+ /* entertry */ 0x0003,
+ /* ghbyname */ 0x0003,
+ /* ghbyaddr */ 0x012f,
+ /* gnbyname */ 0x0003,
+ /* gnbyaddr */ 0x012f,
+ /* gpbyname */ 0x0003,
+ /* gpbynumber */ 0x012f,
+ /* gsbyname */ 0x012f,
+ /* gsbyport */ 0x012f,
+ /* shostent */ 0x0003,
+ /* snetent */ 0x0003,
+ /* sprotoent */ 0x0003,
+ /* sservent */ 0x0003,
+ /* gpwnam */ 0x0003,
+ /* gpwuid */ 0x0003,
+ /* ggrnam */ 0x0003,
+ /* ggrgid */ 0x0003,
+ /* syscall */ 0x012f,
+ /* lock */ 0x0003,
+ /* once */ 0x0003,
+ /* reach */ 0x0003,
+ /* rkeys */ 0x26ac, 0x0003,
+ /* rvalues */ 0x0003,
+ /* coreargs */ 0x277c, 0x0018, 0x0d24, 0x0c41,
+ /* runcv */ 0x00bd,
+ /* fc */ 0x0003,
+ /* padrange */ 0x25bc, 0x019b,
+
+};
+
+
+/* PL_op_private_valid: for each op, indexed by op_type, indicate which
+ * flags bits in op_private are legal */
+
+EXTCONST U8 PL_op_private_valid[] = {
+ /* NULL */ (0xff),
+ /* STUB */ (0),
+ /* SCALAR */ (OPpARG1_MASK),
+ /* PUSHMARK */ (OPpPAD_STATE|OPpLVAL_INTRO),
+ /* WANTARRAY */ (OPpOFFBYONE),
+ /* CONST */ (OPpCONST_NOVER|OPpCONST_SHORTCIRCUIT|OPpCONST_STRICT|OPpCONST_ENTERED|OPpCONST_BARE),
+ /* GVSV */ (OPpOUR_INTRO|OPpLVAL_INTRO),
+ /* GV */ (OPpEARLY_CV),
+ /* GELEM */ (OPpARG2_MASK),
+ /* PADSV */ (OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO),
+ /* PADAV */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpPAD_STATE|OPpLVAL_INTRO),
+ /* PADHV */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpPAD_STATE|OPpTRUEBOOL|OPpMAYBE_TRUEBOOL|OPpLVAL_INTRO),
+ /* PADANY */ (0),
+ /* PUSHRE */ (OPpRUNTIME),
+ /* RV2GV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpDONT_INIT_GV|OPpMAYBE_LVSUB|OPpALLOW_FAKE|OPpDEREF|OPpLVAL_INTRO),
+ /* RV2SV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO),
+ /* AV2ARYLEN */ (OPpARG1_MASK|OPpMAYBE_LVSUB),
+ /* RV2CV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpENTERSUB_HASTARG|OPpENTERSUB_AMPER|OPpENTERSUB_DB|OPpMAY_RETURN_CONSTANT|OPpENTERSUB_NOPAREN),
+ /* ANONCODE */ (0),
+ /* PROTOTYPE */ (OPpARG1_MASK),
+ /* REFGEN */ (OPpARG1_MASK),
+ /* SREFGEN */ (OPpARG1_MASK),
+ /* REF */ (OPpARG1_MASK),
+ /* BLESS */ (OPpARG4_MASK),
+ /* BACKTICK */ (OPpARG1_MASK|OPpOPEN_IN_RAW|OPpOPEN_IN_CRLF|OPpOPEN_OUT_RAW|OPpOPEN_OUT_CRLF),
+ /* GLOB */ (OPpARG4_MASK),
+ /* READLINE */ (OPpARG1_MASK),
+ /* RCATLINE */ (0),
+ /* REGCMAYBE */ (OPpARG1_MASK),
+ /* REGCRESET */ (OPpARG1_MASK),
+ /* REGCOMP */ (OPpARG1_MASK),
+ /* MATCH */ (OPpTARGET_MY|OPpRUNTIME),
+ /* QR */ (OPpRUNTIME),
+ /* SUBST */ (OPpTARGET_MY|OPpRUNTIME),
+ /* SUBSTCONT */ (OPpARG1_MASK|OPpRUNTIME),
+ /* TRANS */ (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTARGET_MY|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE),
+ /* TRANSR */ (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTARGET_MY|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE),
+ /* SASSIGN */ (OPpARG2_MASK|OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV),
+ /* AASSIGN */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpASSIGN_COMMON),
+ /* CHOP */ (OPpARG1_MASK),
+ /* SCHOP */ (OPpARG1_MASK),
+ /* CHOMP */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* SCHOMP */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* DEFINED */ (OPpARG1_MASK),
+ /* UNDEF */ (OPpARG1_MASK),
+ /* STUDY */ (OPpARG1_MASK),
+ /* POS */ (OPpARG1_MASK|OPpMAYBE_LVSUB|OPpLVAL_INTRO),
+ /* PREINC */ (OPpARG1_MASK),
+ /* I_PREINC */ (OPpARG1_MASK),
+ /* PREDEC */ (OPpARG1_MASK),
+ /* I_PREDEC */ (OPpARG1_MASK),
+ /* POSTINC */ (OPpARG1_MASK),
+ /* I_POSTINC */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* POSTDEC */ (OPpARG1_MASK),
+ /* I_POSTDEC */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* POW */ (OPpARG2_MASK|OPpTARGET_MY),
+ /* MULTIPLY */ (OPpARG2_MASK|OPpTARGET_MY),
+ /* I_MULTIPLY */ (OPpARG2_MASK|OPpTARGET_MY),
+ /* DIVIDE */ (OPpARG2_MASK|OPpTARGET_MY),
+ /* I_DIVIDE */ (OPpARG2_MASK|OPpTARGET_MY),
+ /* MODULO */ (OPpARG2_MASK|OPpTARGET_MY),
+ /* I_MODULO */ (OPpARG2_MASK|OPpTARGET_MY),
+ /* REPEAT */ (OPpARG2_MASK|OPpREPEAT_DOLIST),
+ /* ADD */ (OPpARG2_MASK|OPpTARGET_MY),
+ /* I_ADD */ (OPpARG2_MASK|OPpTARGET_MY),
+ /* SUBTRACT */ (OPpARG2_MASK|OPpTARGET_MY),
+ /* I_SUBTRACT */ (OPpARG2_MASK|OPpTARGET_MY),
+ /* CONCAT */ (OPpARG2_MASK|OPpTARGET_MY),
+ /* STRINGIFY */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* LEFT_SHIFT */ (OPpARG2_MASK|OPpTARGET_MY),
+ /* RIGHT_SHIFT */ (OPpARG2_MASK|OPpTARGET_MY),
+ /* LT */ (OPpARG2_MASK),
+ /* I_LT */ (OPpARG2_MASK),
+ /* GT */ (OPpARG2_MASK),
+ /* I_GT */ (OPpARG2_MASK),
+ /* LE */ (OPpARG2_MASK),
+ /* I_LE */ (OPpARG2_MASK),
+ /* GE */ (OPpARG2_MASK),
+ /* I_GE */ (OPpARG2_MASK),
+ /* EQ */ (OPpARG2_MASK),
+ /* I_EQ */ (OPpARG2_MASK),
+ /* NE */ (OPpARG2_MASK),
+ /* I_NE */ (OPpARG2_MASK),
+ /* NCMP */ (OPpARG2_MASK),
+ /* I_NCMP */ (OPpARG2_MASK),
+ /* SLT */ (OPpARG2_MASK),
+ /* SGT */ (OPpARG2_MASK),
+ /* SLE */ (OPpARG2_MASK),
+ /* SGE */ (OPpARG2_MASK),
+ /* SEQ */ (OPpARG2_MASK),
+ /* SNE */ (OPpARG2_MASK),
+ /* SCMP */ (OPpARG2_MASK),
+ /* BIT_AND */ (OPpARG2_MASK),
+ /* BIT_XOR */ (OPpARG2_MASK),
+ /* BIT_OR */ (OPpARG2_MASK),
+ /* NEGATE */ (OPpARG1_MASK),
+ /* I_NEGATE */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* NOT */ (OPpARG1_MASK),
+ /* COMPLEMENT */ (OPpARG1_MASK),
+ /* SMARTMATCH */ (OPpARG2_MASK),
+ /* ATAN2 */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* SIN */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* COS */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* RAND */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* SRAND */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* EXP */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* LOG */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* SQRT */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* INT */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* HEX */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* OCT */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* ABS */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* LENGTH */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* SUBSTR */ (OPpARG3_MASK|OPpMAYBE_LVSUB|OPpSUBSTR_REPL_FIRST|OPpLVAL_INTRO),
+ /* VEC */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpLVAL_INTRO),
+ /* INDEX */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* RINDEX */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* SPRINTF */ (OPpARG4_MASK),
+ /* FORMLINE */ (OPpARG4_MASK),
+ /* ORD */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* CHR */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* CRYPT */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* UCFIRST */ (OPpARG1_MASK),
+ /* LCFIRST */ (OPpARG1_MASK),
+ /* UC */ (OPpARG1_MASK),
+ /* LC */ (OPpARG1_MASK),
+ /* QUOTEMETA */ (OPpARG1_MASK),
+ /* RV2AV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpOUR_INTRO|OPpLVAL_INTRO),
+ /* AELEMFAST */ (255),
+ /* AELEMFAST_LEX */ (255),
+ /* AELEM */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO),
+ /* ASLICE */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpLVAL_INTRO),
+ /* KVASLICE */ (OPpMAYBE_LVSUB),
+ /* AEACH */ (OPpARG1_MASK),
+ /* AKEYS */ (OPpARG1_MASK),
+ /* AVALUES */ (OPpARG1_MASK),
+ /* EACH */ (OPpARG1_MASK),
+ /* VALUES */ (OPpARG1_MASK),
+ /* KEYS */ (OPpARG1_MASK|OPpMAYBE_LVSUB),
+ /* DELETE */ (OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO),
+ /* EXISTS */ (OPpARG1_MASK|OPpEXISTS_SUB),
+ /* RV2HV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpOUR_INTRO|OPpTRUEBOOL|OPpMAYBE_TRUEBOOL|OPpLVAL_INTRO),
+ /* HELEM */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO),
+ /* HSLICE */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpLVAL_INTRO),
+ /* KVHSLICE */ (OPpMAYBE_LVSUB),
+ /* UNPACK */ (OPpARG4_MASK),
+ /* PACK */ (OPpARG4_MASK),
+ /* SPLIT */ (OPpSPLIT_IMPLIM),
+ /* JOIN */ (OPpARG4_MASK),
+ /* LIST */ (OPpLIST_GUESSED|OPpLVAL_INTRO),
+ /* LSLICE */ (OPpARG2_MASK),
+ /* ANONLIST */ (OPpARG4_MASK),
+ /* ANONHASH */ (OPpARG4_MASK),
+ /* SPLICE */ (OPpARG4_MASK),
+ /* PUSH */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* POP */ (OPpARG1_MASK),
+ /* SHIFT */ (OPpARG1_MASK),
+ /* UNSHIFT */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* SORT */ (OPpSORT_NUMERIC|OPpSORT_INTEGER|OPpSORT_REVERSE|OPpSORT_INPLACE|OPpSORT_DESCEND|OPpSORT_QSORT|OPpSORT_STABLE),
+ /* REVERSE */ (OPpARG1_MASK|OPpREVERSE_INPLACE),
+ /* GREPSTART */ (OPpGREP_LEX),
+ /* GREPWHILE */ (OPpARG1_MASK|OPpGREP_LEX),
+ /* MAPSTART */ (OPpGREP_LEX),
+ /* MAPWHILE */ (OPpARG1_MASK|OPpGREP_LEX),
+ /* RANGE */ (OPpARG1_MASK),
+ /* FLIP */ (OPpARG1_MASK|OPpFLIP_LINENUM),
+ /* FLOP */ (OPpARG1_MASK|OPpFLIP_LINENUM),
+ /* AND */ (OPpARG1_MASK),
+ /* OR */ (OPpARG1_MASK),
+ /* XOR */ (OPpARG2_MASK),
+ /* DOR */ (OPpARG1_MASK),
+ /* COND_EXPR */ (OPpARG1_MASK|OPpLVAL_INTRO),
+ /* ANDASSIGN */ (OPpARG1_MASK),
+ /* ORASSIGN */ (OPpARG1_MASK),
+ /* DORASSIGN */ (OPpARG1_MASK),
+ /* METHOD */ (OPpARG1_MASK),
+ /* ENTERSUB */ (OPpENTERSUB_INARGS|OPpHINT_STRICT_REFS|OPpENTERSUB_HASTARG|OPpENTERSUB_AMPER|OPpENTERSUB_DB|OPpDEREF|OPpLVAL_INTRO),
+ /* LEAVESUB */ (OPpARG1_MASK|OPpREFCOUNTED),
+ /* LEAVESUBLV */ (OPpARG1_MASK|OPpREFCOUNTED),
+ /* CALLER */ (OPpARG4_MASK|OPpOFFBYONE),
+ /* WARN */ (OPpARG4_MASK),
+ /* DIE */ (OPpARG4_MASK),
+ /* RESET */ (OPpARG4_MASK),
+ /* LINESEQ */ (0),
+ /* NEXTSTATE */ (OPpHUSH_VMSISH|OPpHINT_M_VMSISH_STATUS|OPpHINT_M_VMSISH_TIME),
+ /* DBSTATE */ (OPpHUSH_VMSISH|OPpHINT_M_VMSISH_STATUS|OPpHINT_M_VMSISH_TIME),
+ /* UNSTACK */ (0),
+ /* ENTER */ (0),
+ /* LEAVE */ (OPpREFCOUNTED|OPpLVALUE),
+ /* SCOPE */ (0),
+ /* ENTERITER */ (OPpITER_REVERSED|OPpITER_DEF|OPpOUR_INTRO|OPpLVAL_INTRO),
+ /* ITER */ (OPpITER_REVERSED),
+ /* ENTERLOOP */ (0),
+ /* LEAVELOOP */ (OPpARG2_MASK|OPpLVALUE),
+ /* RETURN */ (0),
+ /* LAST */ (OPpARG1_MASK|OPpPV_IS_UTF8),
+ /* NEXT */ (OPpARG1_MASK|OPpPV_IS_UTF8),
+ /* REDO */ (OPpARG1_MASK|OPpPV_IS_UTF8),
+ /* DUMP */ (OPpARG1_MASK|OPpPV_IS_UTF8),
+ /* GOTO */ (OPpARG1_MASK|OPpPV_IS_UTF8),
+ /* EXIT */ (OPpARG4_MASK),
+ /* METHOD_NAMED */ (0),
+ /* ENTERGIVEN */ (OPpARG1_MASK),
+ /* LEAVEGIVEN */ (OPpARG1_MASK),
+ /* ENTERWHEN */ (OPpARG1_MASK),
+ /* LEAVEWHEN */ (OPpARG1_MASK),
+ /* BREAK */ (0),
+ /* CONTINUE */ (0),
+ /* OPEN */ (OPpARG4_MASK|OPpOPEN_IN_RAW|OPpOPEN_IN_CRLF|OPpOPEN_OUT_RAW|OPpOPEN_OUT_CRLF),
+ /* CLOSE */ (OPpARG4_MASK),
+ /* PIPE_OP */ (OPpARG4_MASK),
+ /* FILENO */ (OPpARG4_MASK),
+ /* UMASK */ (OPpARG4_MASK),
+ /* BINMODE */ (OPpARG4_MASK),
+ /* TIE */ (OPpARG4_MASK),
+ /* UNTIE */ (OPpARG1_MASK),
+ /* TIED */ (OPpARG1_MASK),
+ /* DBMOPEN */ (OPpARG4_MASK),
+ /* DBMCLOSE */ (OPpARG1_MASK),
+ /* SSELECT */ (OPpARG4_MASK),
+ /* SELECT */ (OPpARG4_MASK),
+ /* GETC */ (OPpARG4_MASK),
+ /* READ */ (OPpARG4_MASK),
+ /* ENTERWRITE */ (OPpARG4_MASK),
+ /* LEAVEWRITE */ (OPpARG1_MASK|OPpREFCOUNTED),
+ /* PRTF */ (0),
+ /* PRINT */ (0),
+ /* SAY */ (0),
+ /* SYSOPEN */ (OPpARG4_MASK),
+ /* SYSSEEK */ (OPpARG4_MASK),
+ /* SYSREAD */ (OPpARG4_MASK),
+ /* SYSWRITE */ (OPpARG4_MASK),
+ /* EOF */ (OPpARG4_MASK),
+ /* TELL */ (OPpARG4_MASK),
+ /* SEEK */ (OPpARG4_MASK),
+ /* TRUNCATE */ (OPpARG4_MASK),
+ /* FCNTL */ (OPpARG4_MASK),
+ /* IOCTL */ (OPpARG4_MASK),
+ /* FLOCK */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* SEND */ (OPpARG4_MASK),
+ /* RECV */ (OPpARG4_MASK),
+ /* SOCKET */ (OPpARG4_MASK),
+ /* SOCKPAIR */ (OPpARG4_MASK),
+ /* BIND */ (OPpARG4_MASK),
+ /* CONNECT */ (OPpARG4_MASK),
+ /* LISTEN */ (OPpARG4_MASK),
+ /* ACCEPT */ (OPpARG4_MASK),
+ /* SHUTDOWN */ (OPpARG4_MASK),
+ /* GSOCKOPT */ (OPpARG4_MASK),
+ /* SSOCKOPT */ (OPpARG4_MASK),
+ /* GETSOCKNAME */ (OPpARG1_MASK),
+ /* GETPEERNAME */ (OPpARG1_MASK),
+ /* LSTAT */ (OPpARG1_MASK),
+ /* STAT */ (OPpARG1_MASK),
+ /* FTRREAD */ (OPpARG1_MASK|OPpFT_ACCESS|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTRWRITE */ (OPpARG1_MASK|OPpFT_ACCESS|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTREXEC */ (OPpARG1_MASK|OPpFT_ACCESS|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTEREAD */ (OPpARG1_MASK|OPpFT_ACCESS|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTEWRITE */ (OPpARG1_MASK|OPpFT_ACCESS|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTEEXEC */ (OPpARG1_MASK|OPpFT_ACCESS|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTIS */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTSIZE */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTMTIME */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTATIME */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTCTIME */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTROWNED */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTEOWNED */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTZERO */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTSOCK */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTCHR */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTBLK */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTFILE */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTDIR */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTPIPE */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTSUID */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTSGID */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTSVTX */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTLINK */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTTTY */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTTEXT */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* FTBINARY */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t),
+ /* CHDIR */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* CHOWN */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* CHROOT */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* UNLINK */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* CHMOD */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* UTIME */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* RENAME */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* LINK */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* SYMLINK */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* READLINK */ (OPpARG1_MASK),
+ /* MKDIR */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* RMDIR */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* OPEN_DIR */ (OPpARG4_MASK),
+ /* READDIR */ (OPpARG1_MASK),
+ /* TELLDIR */ (OPpARG1_MASK),
+ /* SEEKDIR */ (OPpARG4_MASK),
+ /* REWINDDIR */ (OPpARG1_MASK),
+ /* CLOSEDIR */ (OPpARG1_MASK),
+ /* FORK */ (0),
+ /* WAIT */ (OPpTARGET_MY),
+ /* WAITPID */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* SYSTEM */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* EXEC */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* KILL */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* GETPPID */ (OPpTARGET_MY),
+ /* GETPGRP */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* SETPGRP */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* GETPRIORITY */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* SETPRIORITY */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* TIME */ (OPpTARGET_MY),
+ /* TMS */ (0),
+ /* LOCALTIME */ (OPpARG1_MASK),
+ /* GMTIME */ (OPpARG4_MASK),
+ /* ALARM */ (OPpARG1_MASK),
+ /* SLEEP */ (OPpARG4_MASK|OPpTARGET_MY),
+ /* SHMGET */ (OPpARG4_MASK),
+ /* SHMCTL */ (OPpARG4_MASK),
+ /* SHMREAD */ (OPpARG4_MASK),
+ /* SHMWRITE */ (OPpARG4_MASK),
+ /* MSGGET */ (OPpARG4_MASK),
+ /* MSGCTL */ (OPpARG4_MASK),
+ /* MSGSND */ (OPpARG4_MASK),
+ /* MSGRCV */ (OPpARG4_MASK),
+ /* SEMOP */ (OPpARG4_MASK),
+ /* SEMGET */ (OPpARG4_MASK),
+ /* SEMCTL */ (OPpARG4_MASK),
+ /* REQUIRE */ (OPpARG1_MASK),
+ /* DOFILE */ (OPpARG1_MASK),
+ /* HINTSEVAL */ (0),
+ /* ENTEREVAL */ (OPpARG1_MASK|OPpEVAL_HAS_HH|OPpEVAL_UNICODE|OPpEVAL_BYTES|OPpEVAL_COPHH|OPpEVAL_RE_REPARSING),
+ /* LEAVEEVAL */ (OPpARG1_MASK|OPpREFCOUNTED),
+ /* ENTERTRY */ (OPpARG1_MASK),
+ /* LEAVETRY */ (0),
+ /* GHBYNAME */ (OPpARG1_MASK),
+ /* GHBYADDR */ (OPpARG4_MASK),
+ /* GHOSTENT */ (0),
+ /* GNBYNAME */ (OPpARG1_MASK),
+ /* GNBYADDR */ (OPpARG4_MASK),
+ /* GNETENT */ (0),
+ /* GPBYNAME */ (OPpARG1_MASK),
+ /* GPBYNUMBER */ (OPpARG4_MASK),
+ /* GPROTOENT */ (0),
+ /* GSBYNAME */ (OPpARG4_MASK),
+ /* GSBYPORT */ (OPpARG4_MASK),
+ /* GSERVENT */ (0),
+ /* SHOSTENT */ (OPpARG1_MASK),
+ /* SNETENT */ (OPpARG1_MASK),
+ /* SPROTOENT */ (OPpARG1_MASK),
+ /* SSERVENT */ (OPpARG1_MASK),
+ /* EHOSTENT */ (0),
+ /* ENETENT */ (0),
+ /* EPROTOENT */ (0),
+ /* ESERVENT */ (0),
+ /* GPWNAM */ (OPpARG1_MASK),
+ /* GPWUID */ (OPpARG1_MASK),
+ /* GPWENT */ (0),
+ /* SPWENT */ (0),
+ /* EPWENT */ (0),
+ /* GGRNAM */ (OPpARG1_MASK),
+ /* GGRGID */ (OPpARG1_MASK),
+ /* GGRENT */ (0),
+ /* SGRENT */ (0),
+ /* EGRENT */ (0),
+ /* GETLOGIN */ (0),
+ /* SYSCALL */ (OPpARG4_MASK),
+ /* LOCK */ (OPpARG1_MASK),
+ /* ONCE */ (OPpARG1_MASK),
+ /* CUSTOM */ (0xff),
+ /* REACH */ (OPpARG1_MASK),
+ /* RKEYS */ (OPpARG1_MASK|OPpMAYBE_LVSUB),
+ /* RVALUES */ (OPpARG1_MASK),
+ /* COREARGS */ (OPpCOREARGS_DEREF1|OPpCOREARGS_DEREF2|OPpCOREARGS_SCALARMOD|OPpCOREARGS_PUSHMARK),
+ /* RUNCV */ (OPpOFFBYONE),
+ /* FC */ (OPpARG1_MASK),
+ /* PADCV */ (0),
+ /* INTROCV */ (0),
+ /* CLONECV */ (0),
+ /* PADRANGE */ (OPpPADRANGE_COUNTMASK|OPpLVAL_INTRO),
+
+};
+
+# endif /* !DOINIT */
+#endif /* !PERL_GLOBAL_STRUCT_INIT */
+
+END_EXTERN_C
+
+
+
/* ex: set ro: */
AV which is @_. Other entries are storage for variables and op targets.
Iterating over the PADNAMELIST iterates over all possible pad
-items. Pad slots for targets (SVs_PADTMP) and GVs end up having &PL_sv_no
+items. Pad slots for targets (SVs_PADTMP)
+and GVs end up having &PL_sv_undef
"names", while slots for constants have &PL_sv_no "names" (see
pad_alloc()). That &PL_sv_no is used is an implementation detail subject
to change. To test for it, use C<PadnamePV(name) && !PadnameLEN(name)>.
if (! (flags & padnew_CLONE)) {
SAVESPTR(PL_comppad_name);
SAVEI32(PL_padix);
+ SAVEI32(PL_constpadix);
SAVEI32(PL_comppad_name_fill);
SAVEI32(PL_min_intro_pending);
SAVEI32(PL_max_intro_pending);
PL_comppad_name_fill = 0;
PL_min_intro_pending = 0;
PL_padix = 0;
+ PL_constpadix = 0;
PL_cv_has_eval = 0;
}
void
Perl_cv_undef(pTHX_ CV *cv)
{
+ PERL_ARGS_ASSERT_CV_UNDEF;
+ cv_undef_flags(cv, 0);
+}
+
+void
+Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
+{
const PADLIST *padlist = CvPADLIST(cv);
bool const slabbed = !!CvSLABBED(cv);
- PERL_ARGS_ASSERT_CV_UNDEF;
+ PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
DEBUG_X(PerlIO_printf(Perl_debug_log,
"CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
#endif
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
- if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
- else CvGV_set(cv, NULL);
+ if (!(flags & CV_UNDEF_KEEP_NAME)) {
+ if (CvNAMED(cv)) {
+ CvNAME_HEK_set(cv, NULL);
+ CvNAMED_off(cv);
+ }
+ else CvGV_set(cv, NULL);
+ }
/* This statement and the subsequence if block was pad_undef(). */
pad_peg("pad_undef");
CvXSUB(cv) = NULL;
}
/* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
- * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
- * to choose an error message */
- CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
+ * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
+ * LEXICAL, which are used to determine the sub's name. */
+ CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
+ |CVf_NAMED);
}
/*
else {
/* For a tmp, scan the pad from PL_padix upwards
* for a slot which has no name and no active value.
+ * For a constant, likewise, but use PL_constpadix.
*/
SV * const * const names = AvARRAY(PL_comppad_name);
const SSize_t names_fill = AvFILLp(PL_comppad_name);
+ const bool konst = cBOOL(tmptype & SVf_READONLY);
+ retval = konst ? PL_constpadix : PL_padix;
for (;;) {
/*
* Entries that close over unavailable variables
* in outer subs contain values not marked PADMY.
* Thus we must skip, not just pad values that are
* marked as current pad values, but also those with names.
+ * If pad_reset is enabled, ‘current’ means different
+ * things depending on whether we are allocating a con-
+ * stant or a target. For a target, things marked PADTMP
+ * can be reused; not so for constants.
*/
- if (++PL_padix <= names_fill &&
- (sv = names[PL_padix]) && sv != &PL_sv_undef)
+ if (++retval <= names_fill &&
+ (sv = names[retval]) && sv != &PL_sv_undef)
continue;
- sv = *av_fetch(PL_comppad, PL_padix, TRUE);
- if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
- !IS_PADGV(sv))
+ sv = *av_fetch(PL_comppad, retval, TRUE);
+ if (!(SvFLAGS(sv) &
+#ifdef USE_PAD_RESET
+ (SVs_PADMY|(konst ? SVs_PADTMP : 0))
+#else
+ (SVs_PADMY|SVs_PADTMP)
+#endif
+ ))
break;
}
- if (tmptype & SVf_READONLY) {
- av_store(PL_comppad_name, PL_padix, &PL_sv_no);
+ if (konst) {
+ av_store(PL_comppad_name, retval, &PL_sv_no);
tmptype &= ~SVf_READONLY;
tmptype |= SVs_PADTMP;
}
- retval = PL_padix;
+ *(konst ? &PL_constpadix : &PL_padix) = retval;
}
SvFLAGS(sv) |= tmptype;
PL_curpad = AvARRAY(PL_comppad);
if ((PADOFFSET)offset != NOT_IN_PAD)
return offset;
+ /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
+ */
+ if (*namepv == '&') return NOT_IN_PAD;
+
/* look for an our that's being introduced; this allows
* our $foo = 0 unless defined $foo;
* to not give a warning. (Yes, this is a hack) */
nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
name_svp = AvARRAY(nameav);
- for (offset = AvFILLp(nameav); offset > 0; offset--) {
+ for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
const SV * const namesv = name_svp[offset];
if (namesv && PadnameLEN(namesv) == namelen
&& !SvFAKE(namesv)
PL_min_intro_pending = 0;
SAVEI32(PL_comppad_name_fill);
SAVEI32(PL_padix_floor);
+ /* PL_padix_floor is what PL_padix is reset to at the start of each
+ statement, by pad_reset(). We set it when entering a new scope
+ to keep things like this working:
+ print "$foo$bar", do { this(); that() . "foo" };
+ We must not let "$foo$bar" and the later concatenation share the
+ same target. */
PL_padix_floor = PL_padix;
PL_pad_reset_pending = FALSE;
}
/* if pad tmps aren't shared between ops, then there's no need to
* create a new tmp when an existing op is freed */
-#ifdef USE_BROKEN_PAD_RESET
+#ifdef USE_PAD_RESET
PL_curpad[po] = newSV(0);
SvPADTMP_on(PL_curpad[po]);
#else
}
PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
}
- if ((I32)po < PL_padix)
- PL_padix = po - 1;
+ /* Use PL_constpadix here, not PL_padix. The latter may have been
+ reset by pad_reset. We don’t want pad_alloc to have to scan the
+ whole pad when allocating a constant. */
+ if ((I32)po < PL_constpadix)
+ PL_constpadix = po - 1;
}
/*
=cut
*/
-/* XXX pad_reset() is currently disabled because it results in serious bugs.
- * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
- * on the stack by OPs that use them, there are several ways to get an alias
- * to a shared TARG. Such an alias will change randomly and unpredictably.
- * We avoid doing this until we can think of a Better Way.
- * GSAR 97-10-29 */
+/* pad_reset() causes pad temp TARGs (operator targets) to be shared
+ * between OPs from different statements. During compilation, at the start
+ * of each statement pad_reset resets PL_padix back to its previous value.
+ * When allocating a target, pad_alloc begins its scan through the pad at
+ * PL_padix+1. */
static void
S_pad_reset(pTHX)
{
-#ifdef USE_BROKEN_PAD_RESET
+#ifdef USE_PAD_RESET
if (AvARRAY(PL_comppad) != PL_curpad)
Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
AvARRAY(PL_comppad), PL_curpad);
);
if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
- I32 po;
- for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
- if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
- SvPADTMP_off(PL_curpad[po]);
- }
PL_padix = PL_padix_floor;
}
#endif
* pad are anonymous subs, constants and GVs.
* The rest are created anew during cloning.
*/
- if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
- || IS_PADGV(PL_curpad[ix]))
+ if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
continue;
namesv = namep[ix];
if (!(PadnamePV(namesv) &&
PADOFFSET ix;
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
if (!namep[ix]) namep[ix] = &PL_sv_undef;
- if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
- || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
+ if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
continue;
- if (!SvPADMY(PL_curpad[ix])) {
- SvPADTMP_on(PL_curpad[ix]);
- } else if (!SvFAKE(namep[ix])) {
+ if (SvPADMY(PL_curpad[ix]) && !SvFAKE(namep[ix])) {
/* This is a work around for how the current implementation of
?{ } blocks in regexps interacts with lexicals.
void
Perl_pad_free(pTHX_ PADOFFSET po)
{
+#ifndef USE_PAD_RESET
SV *sv;
+#endif
ASSERT_CURPAD_LEGAL("pad_free");
if (!PL_curpad)
return;
PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
);
-
+#ifndef USE_PAD_RESET
sv = PL_curpad[po];
if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
SvFLAGS(sv) &= ~SVs_PADTMP;
if ((I32)po < PL_padix)
PL_padix = po - 1;
+#endif
}
/*
assert(SvTYPE(ppad[ix]) == SVt_PVCV);
subclones = 1;
sv = newSV_type(SVt_PVCV);
+ CvLEXICAL_on(sv);
}
else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
{
/* my sub */
/* Just provide a stub, but name it. It will be
upgrade to the real thing on scope entry. */
+ dVAR;
+ U32 hash;
+ PERL_HASH(hash, SvPVX_const(namesv)+1,
+ SvCUR(namesv) - 1);
sv = newSV_type(SVt_PVCV);
CvNAME_HEK_set(
sv,
share_hek(SvPVX_const(namesv)+1,
SvCUR(namesv) - 1
* (SvUTF8(namesv) ? -1 : 1),
- 0)
+ hash)
);
+ CvLEXICAL_on(sv);
}
else sv = SvREFCNT_inc(ppad[ix]);
else if (sigil == '@')
}
}
}
- else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
+ else if (namesv && PadnamePV(namesv)) {
sv = SvREFCNT_inc_NN(ppad[ix]);
}
else {
}
/*
+=for apidoc cv_name
+
+Returns an SV containing the name of the CV, mainly for use in error
+reporting. The CV may actually be a GV instead, in which case the returned
+SV holds the GV's name. Anything other than a GV or CV is treated as a
+string already holding the sub name, but this could change in the future.
+
+An SV may be passed as a second argument. If so, the name will be assigned
+to it and it will be returned. Otherwise the returned SV will be a new
+mortal.
+
+=cut
+*/
+
+SV *
+Perl_cv_name(pTHX_ CV *cv, SV *sv)
+{
+ PERL_ARGS_ASSERT_CV_NAME;
+ if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
+ if (sv) sv_setsv(sv,(SV *)cv);
+ return sv ? (sv) : (SV *)cv;
+ }
+ {
+ SV * const retsv = sv ? (sv) : sv_newmortal();
+ if (SvTYPE(cv) == SVt_PVCV) {
+ if (CvNAMED(cv)) {
+ if (CvLEXICAL(cv)) sv_sethek(retsv, CvNAME_HEK(cv));
+ else {
+ sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
+ sv_catpvs(retsv, "::");
+ sv_cathek(retsv, CvNAME_HEK(cv));
+ }
+ }
+ else if (CvLEXICAL(cv))
+ sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
+ else gv_efullname3(retsv, CvGV(cv), NULL);
+ }
+ else gv_efullname3(retsv,(GV *)cv,NULL);
+ return retsv;
+ }
+}
+
+/*
=for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
For any anon CVs in the pad, change CvOUTSIDE of that CV from
SvPADMY_on(sv);
}
}
- else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
+ else if (PadnamePV(names[ix])) {
av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
}
else {
}
}
}
- else if (IS_PADGV(oldpad[ix])
- || ( names_fill >= ix && names[ix]
+ else if (( names_fill >= ix && names[ix]
&& PadnamePV(names[ix]) )) {
pad1a[ix] = sv_dup_inc(oldpad[ix], param);
}
=for apidoc m|SV *|PAD_SETSV |PADOFFSET po|SV* sv
Set the slot at offset C<po> in the current pad to C<sv>
-=for apidoc m|void|PAD_SV |PADOFFSET po
+=for apidoc m|SV *|PAD_SV |PADOFFSET po
Get the value at offset C<po> in the current pad
=for apidoc m|SV *|PAD_SVl |PADOFFSET po
U8 lex_defer; /* state after determined token */
U8 lex_dojoin; /* doing an array interpolation
1 = @{...} 2 = ->@ */
- U8 lex_expect; /* expect after determined token */
+ U8 lex_expect; /* UNUSED */
U8 expect; /* how to interpret ambiguous tokens */
I32 lex_formbrack; /* bracket count at outer format level */
OP *lex_inpat; /* in pattern $) and $| are special */
#define PERL_REVISION 5 /* age */
#define PERL_VERSION 21 /* epoch */
-#define PERL_SUBVERSION 3 /* generation */
+#define PERL_SUBVERSION 4 /* generation */
/* The following numbers describe the earliest compatible version of
Perl ("compatibility" here being defined as sufficient binary/API
*/
#define PERL_API_REVISION 5
#define PERL_API_VERSION 21
-#define PERL_API_SUBVERSION 3
+#define PERL_API_SUBVERSION 4
/*
XXX Note: The selection of non-default Configure options, such
as -Duselonglong may invalidate these settings. Currently, Configure
SvREFCNT_dec(PL_utf8_foldable);
SvREFCNT_dec(PL_utf8_foldclosures);
SvREFCNT_dec(PL_AboveLatin1);
+ SvREFCNT_dec(PL_InBitmap);
SvREFCNT_dec(PL_UpperLatin1);
SvREFCNT_dec(PL_Latin1);
SvREFCNT_dec(PL_NonL1NonFinalFold);
PL_utf8_idcont = NULL;
PL_utf8_foldclosures = NULL;
PL_AboveLatin1 = NULL;
+ PL_InBitmap = NULL;
PL_HasMultiCharFold = NULL;
PL_Latin1 = NULL;
PL_NonL1NonFinalFold = NULL;
it should be reported immediately as a build failure. */
(void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
Perl_newSVpvf(aTHX_
- "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} and do q%c%"SVf"/buildcustomize.pl%c || die $@ }",
- 0, SVfARG(*inc0), 0,
- 0, SVfARG(*inc0), 0));
+ "BEGIN { my $f = q%c%s%"SVf"/buildcustomize.pl%c; "
+ "do {local $!; -f $f }"
+ " and do $f || die $@ || qq '$f: $!' }",
+ 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0));
}
# else
/* SITELIB_EXP is a function call on Win32. */
/*
=for apidoc p||eval_pv
-Tells Perl to C<eval> the given string and return an SV* result.
+Tells Perl to C<eval> the given string in scalar context and return an SV* result.
=cut
*/
* if -T are the first chars together; otherwise one gets
* "Too late" message. */
if ( argc > 1 && argv[1][0] == '-'
- && (argv[1][1] == 't' || argv[1][1] == 'T') )
+ && isALPHA_FOLD_EQ(argv[1][1], 't'))
return 1;
return 0;
}
# include "config.h"
#endif
+/* NOTE 1: that with gcc -std=c89 the __STDC_VERSION__ is *not* defined
+ * because the __STDC_VERSION__ became a thing only with C90. Therefore,
+ * with gcc, HAS_C99 will never become true as long as we use -std=c89.
+
+ * NOTE 2: headers lie. Do not expect that if HAS_C99 gets to be true,
+ * all the C99 features are there and are correct. */
+#if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || \
+ defined(_STDC_C99)
+# define HAS_C99 1
+#endif
+
/* See L<perlguts/"The Perl API"> for detailed notes on
* PERL_IMPLICIT_CONTEXT and PERL_IMPLICIT_SYS */
/* gcc -Wall:
* for silencing unused variables that are actually used most of the time,
- * but we cannot quite get rid of, such as "ax" in PPCODE+noargs xsubs
+ * but we cannot quite get rid of, such as "ax" in PPCODE+noargs xsubs,
+ * or variables/arguments that are used only in certain configurations.
*/
#ifndef PERL_UNUSED_ARG
# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
# include <note.h>
# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
# else
-# define PERL_UNUSED_ARG(x) ((void)x)
+# define PERL_UNUSED_ARG(x) ((void)sizeof(x))
# endif
#endif
#ifndef PERL_UNUSED_VAR
-# define PERL_UNUSED_VAR(x) ((void)x)
+# define PERL_UNUSED_VAR(x) ((void)sizeof(x))
#endif
#if defined(USE_ITHREADS) || defined(PERL_GLOBAL_STRUCT)
# endif
#endif
+#ifdef I_STDINT
+# include <stdint.h>
+#endif
+
#include <ctype.h>
#ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */
#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
+#ifdef USE_QUADMATH
+# define my_snprintf Perl_my_snprintf
+# define PERL_MY_SNPRINTF_GUARDED
+#else
#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, max, ...) ({ int len = snprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, snprintf); len; })
# define my_snprintf Perl_my_snprintf
# define PERL_MY_SNPRINTF_GUARDED
#endif
+#endif
+/* There is no quadmath_vsnprintf, and therefore my_vsnprintf()
+ * dies if called under USE_QUADMATH. */
#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, max, ...) ({ int len = vsnprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, vsnprintf); len; })
# ifdef I_SUNMATH
# include <sunmath.h>
# endif
-# define NV_DIG LDBL_DIG
-# ifdef LDBL_MANT_DIG
-# define NV_MANT_DIG LDBL_MANT_DIG
-# endif
-# ifdef LDBL_MIN
-# define NV_MIN LDBL_MIN
-# endif
-# ifdef LDBL_MAX
-# define NV_MAX LDBL_MAX
-# endif
-# ifdef LDBL_MIN_EXP
-# define NV_MIN_EXP LDBL_MIN_EXP
+# if defined(USE_QUADMATH) && defined(I_QUADMATH)
+# include <quadmath.h>
# endif
-# ifdef LDBL_MAX_EXP
-# define NV_MAX_EXP LDBL_MAX_EXP
-# endif
-# ifdef LDBL_MIN_10_EXP
-# define NV_MIN_10_EXP LDBL_MIN_10_EXP
-# endif
-# ifdef LDBL_MAX_10_EXP
-# define NV_MAX_10_EXP LDBL_MAX_10_EXP
-# endif
-# ifdef LDBL_EPSILON
-# define NV_EPSILON LDBL_EPSILON
-# endif
-# ifdef LDBL_MAX
-# define NV_MAX LDBL_MAX
+# ifdef FLT128_DIG
+# define NV_DIG FLT128_DIG
+# define NV_MANT_DIG FLT128_MANT_DIG
+# define NV_MIN FLT128_MIN
+# define NV_MAX FLT128_MAX
+# define NV_MIN_EXP FLT128_MIN_EXP
+# define NV_MAX_EXP FLT128_MAX_EXP
+# define NV_EPSILON FLT128_EPSILON
+# define NV_MIN_10_EXP FLT128_MIN_10_EXP
+# define NV_MAX_10_EXP FLT128_MAX_10_EXP
+# define NV_INF HUGE_VALQ
+# define NV_NAN nanq("0")
+# elif defined(LDBL_DIG)
+# define NV_DIG LDBL_DIG
+# ifdef LDBL_MANT_DIG
+# define NV_MANT_DIG LDBL_MANT_DIG
+# endif
+# ifdef LDBL_MIN
+# define NV_MIN LDBL_MIN
+# endif
+# ifdef LDBL_MAX
+# define NV_MAX LDBL_MAX
+# endif
+# ifdef LDBL_MIN_EXP
+# define NV_MIN_EXP LDBL_MIN_EXP
+# endif
+# ifdef LDBL_MAX_EXP
+# define NV_MAX_EXP LDBL_MAX_EXP
+# endif
+# ifdef LDBL_MIN_10_EXP
+# define NV_MIN_10_EXP LDBL_MIN_10_EXP
+# endif
+# ifdef LDBL_MAX_10_EXP
+# define NV_MAX_10_EXP LDBL_MAX_10_EXP
+# endif
+# ifdef LDBL_EPSILON
+# define NV_EPSILON LDBL_EPSILON
+# endif
+# ifdef LDBL_MAX
+# define NV_MAX LDBL_MAX
/* Having LDBL_MAX doesn't necessarily mean that we have LDBL_MIN... -Allen */
-# else
-# ifdef HUGE_VALL
-# define NV_MAX HUGE_VALL
# else
-# ifdef HUGE_VAL
-# define NV_MAX ((NV)HUGE_VAL)
+# ifdef HUGE_VALL
+# define NV_MAX HUGE_VALL
# endif
# endif
# endif
-# ifdef HAS_SQRTL
+# if defined(USE_QUADMATH) && defined(I_QUADMATH)
+# define Perl_acos acosq
+# define Perl_asin asinq
+# define Perl_atan atanq
+# define Perl_atan2 atan2q
+# define Perl_ceil ceilq
+# define Perl_cos cosq
+# define Perl_cosh coshq
+# define Perl_exp expq
+/* no Perl_fabs, but there's PERL_ABS */
+# define Perl_floor floorq
+# define Perl_fmod fmodq
+# define Perl_log logq
+# define Perl_log10 log10q
+# define Perl_pow powq
+# define Perl_sin sinq
+# define Perl_sinh sinhq
+# define Perl_sqrt sqrtq
+# define Perl_tan tanq
+# define Perl_tanh tanhq
+# define Perl_modf(x,y) modfq(x,y)
+# define Perl_frexp(x,y) frexpq(x,y)
+# define Perl_ldexp(x, y) ldexpq(x,y)
+# define Perl_isinf(x) isinfq(x)
+# define Perl_isnan(x) isnanq(x)
+# define Perl_isfinite(x) !(isnanq(x) || isinfq(x))
+# elif defined(HAS_SQRTL)
+# define Perl_acos acosl
+# define Perl_asin asinl
+# define Perl_atan atanl
+# define Perl_atan2 atan2l
+# define Perl_ceil ceill
# define Perl_cos cosl
-# define Perl_sin sinl
-# define Perl_sqrt sqrtl
+# define Perl_cosh coshl
# define Perl_exp expl
-# define Perl_log logl
-# define Perl_atan2 atan2l
-# define Perl_pow powl
+/* no Perl_fabs, but there's PERL_ABS */
# define Perl_floor floorl
-# define Perl_ceil ceill
# define Perl_fmod fmodl
+# define Perl_log logl
+# define Perl_log10 log10l
+# define Perl_pow powl
+# define Perl_sin sinl
+# define Perl_sinh sinhl
+# define Perl_sqrt sqrtl
+# define Perl_tan tanl
+# define Perl_tanh tanhl
# endif
/* e.g. libsunmath doesn't have modfl and frexpl as of mid-March 2000 */
-# ifdef HAS_MODFL
-# define Perl_modf(x,y) modfl(x,y)
+# ifndef Perl_modf
+# ifdef HAS_MODFL
+# define Perl_modf(x,y) modfl(x,y)
/* eg glibc 2.2 series seems to provide modfl on ppc and arm, but has no
prototype in <math.h> */
-# ifndef HAS_MODFL_PROTO
+# ifndef HAS_MODFL_PROTO
EXTERN_C long double modfl(long double, long double *);
-# endif
-# else
-# if defined(HAS_AINTL) && defined(HAS_COPYSIGNL)
+# endif
+# elif (defined(HAS_TRUNCL) || defined(HAS_AINTL)) && defined(HAS_COPYSIGNL)
extern long double Perl_my_modfl(long double x, long double *ip);
# define Perl_modf(x,y) Perl_my_modfl(x,y)
# endif
# endif
-# ifdef HAS_FREXPL
-# define Perl_frexp(x,y) frexpl(x,y)
-# else
-# if defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
- extern long double Perl_my_frexpl(long double x, int *e);
-# define Perl_frexp(x,y) Perl_my_frexpl(x,y)
+# ifndef Perl_frexp
+# ifdef HAS_FREXPL
+# define Perl_frexp(x,y) frexpl(x,y)
+# else
+# if defined(HAS_ILOGBL) && defined(HAS_SCALBNL)
+extern long double Perl_my_frexpl(long double x, int *e);
+# define Perl_frexp(x,y) Perl_my_frexpl(x,y)
+# endif
# endif
# endif
-# ifdef HAS_LDEXPL
-# define Perl_ldexp(x, y) ldexpl(x,y)
-# else
-# if defined(HAS_SCALBNL) && FLT_RADIX == 2
-# define Perl_ldexp(x,y) scalbnl(x,y)
+# ifndef Perl_ldexp
+# ifdef HAS_LDEXPL
+# define Perl_ldexp(x, y) ldexpl(x,y)
+# else
+# if defined(HAS_SCALBNL) && FLT_RADIX == 2
+# define Perl_ldexp(x,y) scalbnl(x,y)
+# endif
# endif
# endif
# ifndef Perl_isnan
-# ifdef HAS_ISNANL
+# if defined(HAS_ISNANL) && !(defined(isnan) && defined(HAS_C99))
# define Perl_isnan(x) isnanl(x)
# endif
# endif
# ifndef Perl_isinf
-# ifdef HAS_FINITEL
-# define Perl_isinf(x) !(finitel(x)||Perl_isnan(x))
+# if defined(HAS_ISINFL) && !(defined(isinf) && defined(HAS_C99))
+# define Perl_isinf(x) isinfl(x)
+# elif defined(LDBL_MAX)
+# define Perl_isinf(x) ((x) > LDBL_MAX || (x) < -LDBL_MAX)
# endif
# endif
+# ifndef Perl_isfinite
+# define Perl_isfinite(x) Perl_isfinitel(x)
+# endif
#else
# define NV_DIG DBL_DIG
# ifdef DBL_MANT_DIG
# define NV_MAX HUGE_VAL
# endif
# endif
+
+/* These math interfaces are C89. */
+# define Perl_acos acos
+# define Perl_asin asin
+# define Perl_atan atan
+# define Perl_atan2 atan2
+# define Perl_ceil ceil
# define Perl_cos cos
-# define Perl_sin sin
-# define Perl_sqrt sqrt
+# define Perl_cosh cosh
# define Perl_exp exp
-# define Perl_log log
-# define Perl_atan2 atan2
-# define Perl_pow pow
+/* no Perl_fabs, but there's PERL_ABS */
# define Perl_floor floor
-# define Perl_ceil ceil
# define Perl_fmod fmod
+# define Perl_log log
+# define Perl_log10 log10
+# define Perl_pow pow
+# define Perl_sin sin
+# define Perl_sinh sinh
+# define Perl_sqrt sqrt
+# define Perl_tan tan
+# define Perl_tanh tanh
+
# define Perl_modf(x,y) modf(x,y)
# define Perl_frexp(x,y) frexp(x,y)
# define Perl_ldexp(x,y) ldexp(x,y)
+
+# ifndef Perl_isnan
+# ifdef HAS_ISNAN
+# define Perl_isnan(x) isnan(x)
+# endif
+# endif
+# ifndef Perl_isinf
+# if defined(HAS_ISINF)
+# define Perl_isinf(x) isinf(x)
+# elif defined(DBL_MAX)
+# define Perl_isinf(x) ((x) > DBL_MAX || (x) < -DBL_MAX)
+# endif
+# endif
+# ifndef Perl_isfinite
+# ifdef HAS_ISFINITE
+# define Perl_isfinite(x) isfinite(x)
+# elif defined(HAS_FINITE)
+# define Perl_isfinite(x) finite(x)
+# endif
+# endif
+#endif
+
+/* fpclassify(): C99. It is supposed to be a macro that switches on
+* the sizeof() of its argument, so there's no need for e.g. fpclassifyl().*/
+#if !defined(Perl_fp_class) && defined(HAS_FPCLASSIFY)
+# include <math.h>
+# if defined(FP_INFINITE) && defined(FP_NAN)
+# define Perl_fp_class(x) fpclassify(x)
+# define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_INFINITE)
+# define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_NAN)
+# define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_NORMAL)
+# define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_SUBNORMAL)
+# define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_ZERO)
+# elif defined(FP_PLUS_INF) && defined(FP_QNAN)
+/* Some versions of HP-UX (10.20) have (only) fpclassify() but which is
+ * actually not the C99 fpclassify, with its own set of return defines. */
+# define Perl_fp_class(x) fpclassify(x)
+# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PLUS_INF)
+# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_MINUS_INF)
+# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_SNAN)
+# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_QNAN)
+# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PLUS_NORM)
+# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_MINUS_NORM)
+# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PLUS_DENORM)
+# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM)
+# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PLUS_ZERO)
+# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_MINUS_ZERO)
+# else
+# undef Perl_fp_class /* Unknown set of defines */
+# endif
#endif
-/* rumor has it that Win32 has _fpclass() */
+/* fp_classify(): Legacy: VMS, maybe Unicos? The values, however,
+ * are identical to the C99 fpclassify(). */
+#if !defined(Perl_fp_class) && defined(HAS_FP_CLASSIFY)
+# include <math.h>
+# ifdef __VMS
+ /* FP_INFINITE and others are here rather than in math.h as C99 stipulates */
+# include <fp.h>
+ /* oh, and the isnormal macro has a typo in it! */
+# undef isnormal
+# define isnormal(x) Perl_fp_class_norm(x)
+# endif
+# if defined(FP_INFINITE) && defined(FP_NAN)
+# define Perl_fp_class(x) fp_classify(x)
+# define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_INFINITE)
+# define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_NAN)
+# define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_NORMAL)
+# define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_SUBNORMAL)
+# define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_ZERO)
+# else
+# undef Perl_fp_class /* Unknown set of defines */
+# endif
+#endif
-/* SGI has fpclassl... but not with the same result values,
- * and it's via a typedef (not via #define), so will need to redo Configure
- * to use. Not worth the trouble, IMO, at least until the below is used
- * more places. Also has fp_class_l, BTW, via fp_class.h. Feel free to check
- * with me for the SGI manpages, SGI testing, etcetera, if you want to
- * try getting this to work with IRIX. - Allen <allens@cpan.org> */
+/* Feel free to check with me for the SGI manpages, SGI testing,
+ * etcetera, if you want to try getting this to work with IRIX.
+ *
+ * - Allen <allens@cpan.org> */
+/* fpclass(): SysV, at least Solaris and some versions of IRIX. */
#if !defined(Perl_fp_class) && (defined(HAS_FPCLASS)||defined(HAS_FPCLASSL))
+/* Solaris and IRIX have fpclass/fpclassl, but they are using
+ * an enum typedef, not cpp symbols, and Configure doesn't detect that.
+ * Define some symbols also as cpp symbols so we can detect them. */
+# if defined(__sun) || defined(__irix__) /* XXX Configure test instead */
+# define FP_PINF FP_PINF
+# define FP_QNAN FP_QNAN
+# endif
+# include <math.h>
# ifdef I_IEEFP
# include <ieeefp.h>
# endif
# include <fp.h>
# endif
# if defined(USE_LONG_DOUBLE) && defined(HAS_FPCLASSL)
-# define Perl_fp_class() fpclassl(x)
+# define Perl_fp_class(x) fpclassl(x)
# else
-# define Perl_fp_class() fpclass(x)
+# define Perl_fp_class(x) fpclass(x)
# endif
-# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_CLASS_SNAN)
-# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_CLASS_QNAN)
-# define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_CLASS_SNAN||Perl_fp_class(x)==FP_CLASS_QNAN)
-# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_CLASS_NINF)
-# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_CLASS_PINF)
-# define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_CLASS_NINF||Perl_fp_class(x)==FP_CLASS_PINF)
-# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_CLASS_NNORM)
-# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_CLASS_PNORM)
-# define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_CLASS_NNORM||Perl_fp_class(x)==FP_CLASS_PNORM)
-# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_CLASS_NDENORM)
-# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_CLASS_PDENORM)
-# define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_CLASS_NDENORM||Perl_fp_class(x)==FP_CLASS_PDENORM)
-# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_CLASS_NZERO)
-# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_CLASS_PZERO)
-# define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_CLASS_NZERO||Perl_fp_class(x)==FP_CLASS_PZERO)
-#endif
-
-#if !defined(Perl_fp_class) && defined(HAS_FP_CLASS)
-# include <math.h>
-# if !defined(FP_SNAN) && defined(I_FP_CLASS)
-# include <fp_class.h>
+# if defined(FP_CLASS_PINF) && defined(FP_CLASS_SNAN)
+# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_CLASS_SNAN)
+# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_CLASS_QNAN)
+# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_CLASS_NINF)
+# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_CLASS_PINF)
+# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_CLASS_NNORM)
+# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_CLASS_PNORM)
+# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_CLASS_NDENORM)
+# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_CLASS_PDENORM)
+# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_CLASS_NZERO)
+# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_CLASS_PZERO)
+# elif defined(FP_PINF) && defined(FP_QNAN)
+# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_SNAN)
+# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_QNAN)
+# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_NINF)
+# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PINF)
+# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_NNORM)
+# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PNORM)
+# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_NDENORM)
+# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PDENORM)
+# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_NZERO)
+# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PZERO)
+# else
+# undef Perl_fp_class /* Unknown set of defines */
# endif
-# define Perl_fp_class(x) fp_class(x)
-# define Perl_fp_class_snan(x) (fp_class(x)==FP_SNAN)
-# define Perl_fp_class_qnan(x) (fp_class(x)==FP_QNAN)
-# define Perl_fp_class_nan(x) (fp_class(x)==FP_SNAN||fp_class(x)==FP_QNAN)
-# define Perl_fp_class_ninf(x) (fp_class(x)==FP_NEG_INF)
-# define Perl_fp_class_pinf(x) (fp_class(x)==FP_POS_INF)
-# define Perl_fp_class_inf(x) (fp_class(x)==FP_NEG_INF||fp_class(x)==FP_POS_INF)
-# define Perl_fp_class_nnorm(x) (fp_class(x)==FP_NEG_NORM)
-# define Perl_fp_class_pnorm(x) (fp_class(x)==FP_POS_NORM)
-# define Perl_fp_class_norm(x) (fp_class(x)==FP_NEG_NORM||fp_class(x)==FP_POS_NORM)
-# define Perl_fp_class_ndenorm(x) (fp_class(x)==FP_NEG_DENORM)
-# define Perl_fp_class_pdenorm(x) (fp_class(x)==FP_POS_DENORM)
-# define Perl_fp_class_denorm(x) (fp_class(x)==FP_NEG_DENORM||fp_class(x)==FP_POS_DENORM)
-# define Perl_fp_class_nzero(x) (fp_class(x)==FP_NEG_ZERO)
-# define Perl_fp_class_pzero(x) (fp_class(x)==FP_POS_ZERO)
-# define Perl_fp_class_zero(x) (fp_class(x)==FP_NEG_ZERO||fp_class(x)==FP_POS_ZERO)
#endif
-#if !defined(Perl_fp_class) && defined(HAS_FPCLASSIFY)
+/* fp_class(): Legacy: at least Tru64, some versions of IRIX. */
+#if !defined(Perl_fp_class) && (defined(HAS_FP_CLASS)||defined(HAS_FP_CLASSL))
# include <math.h>
-# define Perl_fp_class(x) fpclassify(x)
-# define Perl_fp_class_nan(x) (fp_classify(x)==FP_SNAN||fp_classify(x)==FP_QNAN)
-# define Perl_fp_class_inf(x) (fp_classify(x)==FP_INFINITE)
-# define Perl_fp_class_norm(x) (fp_classify(x)==FP_NORMAL)
-# define Perl_fp_class_denorm(x) (fp_classify(x)==FP_SUBNORMAL)
-# define Perl_fp_class_zero(x) (fp_classify(x)==FP_ZERO)
+# if !defined(FP_SNAN) && defined(I_FP_CLASS)
+# include <fp_class.h>
+# endif
+# if defined(FP_POS_INF) && defined(FP_QNAN)
+# ifdef __irix__ /* XXX Configure test instead */
+# ifdef USE_LONG_DOUBLE
+# define Perl_fp_class(x) fp_class_l(x)
+# else
+# define Perl_fp_class(x) fp_class_d(x)
+# endif
+# else
+# if defined(USE_LONG_DOUBLE) && defined(HAS_FP_CLASSL)
+# define Perl_fp_class(x) fp_classl(x)
+# else
+# define Perl_fp_class(x) fp_class(x)
+# endif
+# endif
+# if defined(FP_POS_INF) && defined(FP_QNAN)
+# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_SNAN)
+# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_QNAN)
+# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_NEG_INF)
+# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_POS_INF)
+# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_NEG_NORM)
+# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_POS_NORM)
+# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_NEG_DENORM)
+# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_POS_DENORM)
+# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_NEG_ZERO)
+# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_POS_ZERO)
+# else
+# undef Perl_fp_class /* Unknown set of defines */
+# endif
+# endif
#endif
+/* class(), _class(): Legacy: AIX. */
#if !defined(Perl_fp_class) && defined(HAS_CLASS)
# include <math.h>
-# ifndef _cplusplus
-# define Perl_fp_class(x) class(x)
-# else
-# define Perl_fp_class(x) _class(x)
+# if defined(FP_PLUS_NORM) && defined(FP_PLUS_INF)
+# ifndef _cplusplus
+# define Perl_fp_class(x) class(x)
+# else
+# define Perl_fp_class(x) _class(x)
+# endif
+# if defined(FP_PLUS_INF) && defined(FP_NANQ)
+# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_NANS)
+# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_NANQ)
+# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_MINUS_INF)
+# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PLUS_INF)
+# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_MINUS_NORM)
+# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PLUS_NORM)
+# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM)
+# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PLUS_DENORM)
+# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_MINUS_ZERO)
+# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PLUS_ZERO)
+# else
+# undef Perl_fp_class /* Unknown set of defines */
+# endif
# endif
-# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_NANS)
-# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_NANQ)
-# define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_SNAN||Perl_fp_class(x)==FP_QNAN)
-# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_MINUS_INF)
-# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PLUS_INF)
-# define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_MINUS_INF||Perl_fp_class(x)==FP_PLUS_INF)
-# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_MINUS_NORM)
-# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PLUS_NORM)
-# define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_MINUS_NORM||Perl_fp_class(x)==FP_PLUS_NORM)
-# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM)
-# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PLUS_DENORM)
-# define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM||Perl_fp_class(x)==FP_PLUS_DENORM)
-# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_MINUS_ZERO)
-# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PLUS_ZERO)
-# define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_MINUS_ZERO||Perl_fp_class(x)==FP_PLUS_ZERO)
-#endif
-
-/* rumor has it that Win32 has _isnan() */
+#endif
-#ifndef Perl_isnan
-# ifdef HAS_ISNAN
-# define Perl_isnan(x) isnan((NV)x)
-# else
-# ifdef Perl_fp_class_nan
-# define Perl_isnan(x) Perl_fp_class_nan(x)
-# else
-# ifdef HAS_UNORDERED
-# define Perl_isnan(x) unordered((x), 0.0)
-# else
-# define Perl_isnan(x) ((x)!=(x))
-# endif
-# endif
-# endif
+/* Win32: _fpclass(), _isnan(), _finite(). */
+#ifdef WIN32
+# ifndef Perl_isnan
+# define Perl_isnan(x) _isnan(x)
+# endif
+# ifndef Perl_isfinite
+# define Perl_isfinite(x) _finite(x)
+# endif
+# ifndef Perl_fp_class_snan
+/* No simple way to #define Perl_fp_class because _fpclass()
+ * returns a set of bits. */
+# define Perl_fp_class_snan(x) (_fpclass(x) & _FPCLASS_SNAN)
+# define Perl_fp_class_qnan(x) (_fpclass(x) & _FPCLASS_QNAN)
+# define Perl_fp_class_nan(x) (_fpclass(x) & (_FPCLASS_SNAN|_FPCLASS_QNAN))
+# define Perl_fp_class_ninf(x) (_fpclass(x) & _FPCLASS_NINF))
+# define Perl_fp_class_pinf(x) (_fpclass(x) & _FPCLASS_PINF))
+# define Perl_fp_class_inf(x) (_fpclass(x) & (_FPCLASS_NINF|_FPCLASS_PINF))
+# define Perl_fp_class_nnorm(x) (_fpclass(x) & _FPCLASS_NN)
+# define Perl_fp_class_pnorm(x) (_fpclass(x) & _FPCLASS_PN)
+# define Perl_fp_class_norm(x) (_fpclass(x) & (_FPCLASS_NN|_FPCLASS_PN))
+# define Perl_fp_class_ndenorm(x) (_fpclass(x) & _FPCLASS_ND)
+# define Perl_fp_class_pdenorm(x) (_fpclass(x) & _FPCLASS_PD)
+# define Perl_fp_class_denorm(x) (_fpclass(x) & (_FPCLASS_ND|_FPCLASS_PD))
+# define Perl_fp_class_nzero(x) (_fpclass(x) & _FPCLASS_NZ)
+# define Perl_fp_class_pzero(x) (_fpclass(x) & _FPCLASS_PZ)
+# define Perl_fp_class_zero(x) (_fpclass(x) & (_FPCLASS_NZ|_FPCLASS_PZ))
+# endif
+#endif
+
+#if !defined(Perl_fp_class_inf) && \
+ defined(Perl_fp_class_pinf) && defined(Perl_fp_class_ninf)
+# define Perl_fp_class_inf(x) \
+ (Perl_fp_class_pinf(x) || Perl_fp_class_ninf(x))
+#endif
+
+#if !defined(Perl_fp_class_nan) && \
+ defined(Perl_fp_class_snan) && defined(Perl_fp_class_qnan)
+# define Perl_fp_class_nan(x) \
+ (Perl_fp_class_snan(x) || Perl_fp_class_qnan(x))
+#endif
+
+#if !defined(Perl_fp_class_zero) && \
+ defined(Perl_fp_class_pzero) && defined(Perl_fp_class_nzero)
+# define Perl_fp_class_zero(x) \
+ (Perl_fp_class_pzero(x) || Perl_fp_class_nzero(x))
+#endif
+
+#if !defined(Perl_fp_class_norm) && \
+ defined(Perl_fp_class_pnorm) && defined(Perl_fp_class_nnorm)
+# define Perl_fp_class_norm(x) \
+ (Perl_fp_class_pnorm(x) || Perl_fp_class_nnorm(x))
+#endif
+
+#if !defined(Perl_fp_class_denorm) && \
+ defined(Perl_fp_class_pdenorm) && defined(Perl_fp_class_ndenorm)
+# define Perl_fp_class_denorm(x) \
+ (Perl_fp_class_pdenorm(x) || Perl_fp_class_ndenorm(x))
#endif
#ifdef UNDER_CE
int isnan(double d);
#endif
-#ifndef Perl_isinf
-# ifdef HAS_ISINF
-# define Perl_isinf(x) isinf((NV)x)
+#ifndef Perl_isnan
+# ifdef Perl_fp_class_nan
+# define Perl_isnan(x) Perl_fp_class_nan(x)
# else
-# ifdef Perl_fp_class_inf
-# define Perl_isinf(x) Perl_fp_class_inf(x)
+# ifdef HAS_UNORDERED
+# define Perl_isnan(x) unordered((x), 0.0)
# else
-# define Perl_isinf(x) ((x)==NV_INF)
+# define Perl_isnan(x) ((x)!=(x))
# endif
# endif
#endif
+#ifndef Perl_isinf
+# ifdef Perl_fp_class_inf
+# define Perl_isinf(x) Perl_fp_class_inf(x)
+# endif
+#endif
+
#ifndef Perl_isfinite
-# ifdef HAS_FINITE
-# define Perl_isfinite(x) finite((NV)x)
+# if defined(HAS_ISFINITE) && !defined(isfinite)
+# define Perl_isfinite(x) isfinite((double)(x))
+# elif defined(HAS_FINITE)
+# define Perl_isfinite(x) finite((double)(x))
+# elif defined(Perl_fp_class_finite)
+# define Perl_isfinite(x) Perl_fp_class_finite(x)
# else
-# ifdef HAS_ISFINITE
-# define Perl_isfinite(x) isfinite(x)
-# else
-# ifdef Perl_fp_class_finite
-# define Perl_isfinite(x) Perl_fp_class_finite(x)
-# else
-# define Perl_isfinite(x) !(Perl_is_inf(x)||Perl_is_nan(x))
-# endif
-# endif
+/* For the infinities the multiplication returns nan,
+ * for the nan the multiplication also returns nan,
+ * for everything else (that is, finite) zero should be returned. */
+# define Perl_isfinite(x) (((x) * 0) == 0)
+# endif
+#endif
+
+#ifndef Perl_isinf
+# if defined(Perl_isfinite) && defined(Perl_isnan)
+# define Perl_isinf(x) !(Perl_isfinite(x)||Perl_isnan(x))
# endif
#endif
+/* We need Perl_isfinitel (ends with ell) (if available) even when
+ * not USE_LONG_DOUBLE because the printf code (sv_catpvfn_flags)
+ * needs that. */
+#if defined(HAS_LONG_DOUBLE) && !defined(Perl_isfinitel)
+/* If isfinite() is a macro and looks like we have C99,
+ * we assume it's the type-aware C99 isfinite(). */
+# if defined(HAS_ISFINITE) && defined(isfinite) && defined(HAS_C99)
+# define Perl_isfinitel(x) isfinite(x)
+# elif defined(HAS_ISFINITEL)
+# define Perl_isfinitel(x) isfinitel(x)
+# elif defined(HAS_FINITEL)
+# define Perl_isfinitel(x) finitel(x)
+# elif defined(HAS_INFL) && defined(HAS_NANL)
+# define Perl_isfinitel(x) !(isinfl(x)||isnanl(x))
+# else
+# define Perl_isfinitel(x) ((x) * 0 == 0) /* See Perl_isfinite. */
+# endif
+#endif
+
/* The default is to use Perl's own atof() implementation (in numeric.c).
* Usually that is the one to use but for some platforms (e.g. UNICOS)
* it is however best to use the native implementation of atof.
#ifdef I_MATH
# include <math.h>
+# ifdef __VMS
+ /* isfinite and others are here rather than in math.h as C99 stipulates */
+# include <fp.h>
+# endif
#else
START_EXTERN_C
double exp (double);
END_EXTERN_C
#endif
-#if !defined(NV_INF) && defined(USE_LONG_DOUBLE) && defined(LDBL_INFINITY)
-# define NV_INF LDBL_INFINITY
+#ifdef WIN32
+# if !defined(NV_INF) && defined(HUGE_VAL)
+# define NV_INF HUGE_VAL
+# endif
+/* For WIN32 the best NV_NAN is the __PL_nan_u trick, see below.
+ * There is no supported way of getting the NAN across all the crts. */
+#endif
+
+/* If you are thinking of using HUGE_VAL for infinity, or using
+ * <math.h> functions to generate NV_INF (e.g. exp(1e9), log(-1.0)),
+ * stop. Neither will work portably: HUGE_VAL can be just DBL_MAX,
+ * and the math functions might be just generating DBL_MAX, or even
+ * zero. */
+
+#if !defined(NV_INF) && defined(USE_LONG_DOUBLE)
+# if !defined(NV_INF) && defined(LDBL_INFINITY)
+# define NV_INF LDBL_INFINITY
+# endif
+# if !defined(NV_INF) && defined(INFINITYL)
+# define NV_INF INFINITYL
+# endif
#endif
#if !defined(NV_INF) && defined(DBL_INFINITY)
# define NV_INF (NV)DBL_INFINITY
#if !defined(NV_INF) && defined(INF)
# define NV_INF (NV)INF
#endif
-#if !defined(NV_INF) && defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
-# define NV_INF (NV)HUGE_VALL
+#if !defined(NV_INF)
+# if INTSIZE == 4
+/* At this point we assume the IEEE 754 floating point (and of course,
+ * we also assume a floating point format that can encode an infinity).
+ * We will coerce an int32 (which will encode the infinity) into
+ * a 32-bit float, which will then be cast into NV.
+ *
+ * Note that we intentionally use a float and 32-bit int, instead of
+ * shifting a small integer into a full IV, and from that into a full
+ * NV, because:
+ *
+ * (1) an IV might not be wide enough to cover all the bits of an NV.
+ * (2) the exponent part (including the infinity and nan bits) of a NV
+ * might be wider than just 16 bits.
+ *
+ * Below the NV_NAN logic has similar __PL_nan_u fallback, the only
+ * difference being the int32 constant being coerced. */
+# define __PL_inf_float_int32 0x7F800000
+static const union { unsigned int __i; float __f; } __PL_inf_u =
+ { __PL_inf_float_int32 };
+# define NV_INF ((NV)(__PL_inf_u.__f))
+# endif
#endif
-#if !defined(NV_INF) && defined(HUGE_VAL)
-# define NV_INF (NV)HUGE_VAL
+#if !defined(NV_INF)
+# define NV_INF ((NV)1.0/0.0) /* Some compilers will warn. */
#endif
#if !defined(NV_NAN) && defined(USE_LONG_DOUBLE)
# if !defined(NV_NAN) && defined(LDBL_NAN)
# define NV_NAN LDBL_NAN
# endif
+# if !defined(NV_NAN) && defined(NANL)
+# define NV_NAN NANL
+# endif
# if !defined(NV_NAN) && defined(LDBL_QNAN)
# define NV_NAN LDBL_QNAN
# endif
#if !defined(NV_NAN) && defined(DBL_SNAN)
# define NV_NAN (NV)DBL_SNAN
#endif
+#if !defined(NV_NAN) && defined(NAN)
+# define NV_NAN (NV)NAN
+#endif
#if !defined(NV_NAN) && defined(QNAN)
# define NV_NAN (NV)QNAN
#endif
#if !defined(NV_NAN) && defined(SNAN)
# define NV_NAN (NV)SNAN
#endif
-#if !defined(NV_NAN) && defined(NAN)
-# define NV_NAN (NV)NAN
+#if !defined(NV_NAN)
+# if INTSIZE == 4
+/* See the discussion near __PL_inf_u. */
+# define __PL_nan_float_int32 0x7FC00000
+static const union { unsigned int __i; float __f; } __PL_nan_u =
+ { __PL_nan_float_int32 };
+# define NV_NAN ((NV)(__PL_nan_u.__f))
+# endif
#endif
+#if !defined(NV_NAN)
+# define NV_NAN ((NV)0.0/0.0) /* Some compilers will warn. */
+#endif
+/* Do NOT try doing NV_NAN based on NV_INF and trying (NV_INF-NV_INF).
+ * Though IEEE-754-logically correct, some compilers (like Visual C 2003)
+ * falsely misoptimize that to zero (x-x is zero, right?) */
#ifndef __cplusplus
# if !defined(WIN32) && !defined(VMS)
# ifdef USE_PERLIO
" USE_PERLIO"
# endif
+# ifdef USE_QUADMATH
+ " USE_QUADMATH"
+# endif
# ifdef USE_REENTRANT_API
" USE_REENTRANT_API"
# endif
#endif /* !USE_LOCALE_NUMERIC */
+#ifdef USE_QUADMATH
+# define Perl_strtod(s, e) strtoflt128(s, e)
+#elif defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
+# if defined(HAS_STRTOLD)
+# define Perl_strtod(s, e) strtold(s, e)
+# elif defined(HAS_STRTOD)
+# define Perl_strtod(s, e) (NV)strtod(s, e) /* Unavoidable loss. */
+# endif
+#elif defined(HAS_STRTOD)
+# define Perl_strtod(s, e) strtod(s, e)
+#endif
+
#if !defined(Strtol) && defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && \
(QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64)
# ifdef __hpux
case 2:
#line 114 "perly.y"
{
- PL_parser->expect = XSTATE;
- }
+ parser->expect = XSTATE;
+ ;}
break;
case 3:
{
newPROG(block_end((ps[(3) - (4)].val.ival),(ps[(4) - (4)].val.opval)));
(yyval.ival) = 0;
- }
+ ;}
break;
case 4:
#line 123 "perly.y"
{
parser->expect = XTERM;
- }
+ ;}
break;
case 5:
{
PL_eval_root = (ps[(3) - (3)].val.opval);
(yyval.ival) = 0;
- }
+ ;}
break;
case 6:
#line 132 "perly.y"
{
parser->expect = XBLOCK;
- }
+ ;}
break;
case 7:
(yyval.ival) = 0;
yyunlex();
parser->yychar = YYEOF;
- }
+ ;}
break;
case 8:
#line 144 "perly.y"
{
parser->expect = XSTATE;
- }
+ ;}
break;
case 9:
(yyval.ival) = 0;
yyunlex();
parser->yychar = YYEOF;
- }
+ ;}
break;
case 10:
#line 156 "perly.y"
{
parser->expect = XSTATE;
- }
+ ;}
break;
case 11:
(yyval.ival) = 0;
yyunlex();
parser->yychar = YYEOF;
- }
+ ;}
break;
case 12:
#line 168 "perly.y"
{
parser->expect = XSTATE;
- }
+ ;}
break;
case 13:
{
PL_eval_root = (ps[(3) - (3)].val.opval);
(yyval.ival) = 0;
- }
+ ;}
break;
case 14:
#line 180 "perly.y"
- { if (PL_parser->copline > (line_t)(ps[(1) - (4)].val.ival))
- PL_parser->copline = (line_t)(ps[(1) - (4)].val.ival);
+ { if (parser->copline > (line_t)(ps[(1) - (4)].val.ival))
+ parser->copline = (line_t)(ps[(1) - (4)].val.ival);
(yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval));
- }
+ ;}
break;
case 15:
#line 188 "perly.y"
- { if (PL_parser->copline > (line_t)(ps[(1) - (7)].val.ival))
- PL_parser->copline = (line_t)(ps[(1) - (7)].val.ival);
+ { if (parser->copline > (line_t)(ps[(1) - (7)].val.ival))
+ parser->copline = (line_t)(ps[(1) - (7)].val.ival);
(yyval.opval) = block_end((ps[(2) - (7)].val.ival), (ps[(5) - (7)].val.opval));
- }
+ ;}
break;
case 16:
#line 195 "perly.y"
- { (yyval.ival) = block_start(TRUE); }
+ { (yyval.ival) = block_start(TRUE); ;}
break;
case 17:
#line 199 "perly.y"
- { if (PL_parser->copline > (line_t)(ps[(1) - (4)].val.ival))
- PL_parser->copline = (line_t)(ps[(1) - (4)].val.ival);
+ { if (parser->copline > (line_t)(ps[(1) - (4)].val.ival))
+ parser->copline = (line_t)(ps[(1) - (4)].val.ival);
(yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval));
- }
+ ;}
break;
case 18:
#line 206 "perly.y"
- { (yyval.ival) = block_start(FALSE); }
+ { (yyval.ival) = block_start(FALSE); ;}
break;
case 19:
#line 211 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 20:
PL_pad_reset_pending = TRUE;
if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval))
PL_hints |= HINT_BLOCK_SCOPE;
- }
+ ;}
break;
case 21:
#line 222 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 22:
PL_pad_reset_pending = TRUE;
if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval))
PL_hints |= HINT_BLOCK_SCOPE;
- }
+ ;}
break;
case 23:
#line 233 "perly.y"
{
(yyval.opval) = (ps[(1) - (1)].val.opval) ? newSTATEOP(0, NULL, (ps[(1) - (1)].val.opval)) : NULL;
- }
+ ;}
break;
case 24:
#line 237 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 25:
#line 241 "perly.y"
{
(yyval.opval) = newSTATEOP(SVf_UTF8 * (ps[(1) - (2)].val.pval)[strlen((ps[(1) - (2)].val.pval))+1], (ps[(1) - (2)].val.pval), (ps[(2) - (2)].val.opval));
- }
+ ;}
break;
case 26:
#line 245 "perly.y"
{
(yyval.opval) = newSTATEOP(SVf_UTF8 * (ps[(1) - (2)].val.pval)[strlen((ps[(1) - (2)].val.pval))+1], (ps[(1) - (2)].val.pval), (ps[(2) - (2)].val.opval));
- }
+ ;}
break;
case 27:
#line 252 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 28:
SvREFCNT_inc_simple_void(fmtcv);
pad_add_anon(fmtcv, OP_NULL);
}
- }
+ ;}
break;
case 29:
CvOUTSIDE(PL_compcv)
))[(ps[(2) - (3)].val.opval)->op_targ]))
CvCLONE_on(PL_compcv);
- PL_parser->in_my = 0;
- PL_parser->in_my_stash = NULL;
- }
+ parser->in_my = 0;
+ parser->in_my_stash = NULL;
+ ;}
break;
case 30:
;
(yyval.opval) = (OP*)NULL;
intro_my();
- }
+ ;}
break;
case 31:
if ((ps[(2) - (4)].val.opval))
package_version((ps[(2) - (4)].val.opval));
(yyval.opval) = (OP*)NULL;
- }
+ ;}
break;
case 32:
#line 303 "perly.y"
- { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ }
+ { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ ;}
break;
case 33:
SvREFCNT_inc_simple_void(PL_compcv);
utilize((ps[(1) - (7)].val.ival), (ps[(2) - (7)].val.ival), (ps[(4) - (7)].val.opval), (ps[(5) - (7)].val.opval), (ps[(6) - (7)].val.opval));
(yyval.opval) = (OP*)NULL;
- }
+ ;}
break;
case 34:
{
(yyval.opval) = block_end((ps[(3) - (7)].val.ival),
newCONDOP(0, (ps[(4) - (7)].val.opval), op_scope((ps[(6) - (7)].val.opval)), (ps[(7) - (7)].val.opval)));
- PL_parser->copline = (line_t)(ps[(1) - (7)].val.ival);
- }
+ parser->copline = (line_t)(ps[(1) - (7)].val.ival);
+ ;}
break;
case 35:
{
(yyval.opval) = block_end((ps[(3) - (7)].val.ival),
newCONDOP(0, (ps[(4) - (7)].val.opval), op_scope((ps[(6) - (7)].val.opval)), (ps[(7) - (7)].val.opval)));
- PL_parser->copline = (line_t)(ps[(1) - (7)].val.ival);
- }
+ parser->copline = (line_t)(ps[(1) - (7)].val.ival);
+ ;}
break;
case 36:
|| PAD_COMPNAME_FLAGS_isOUR(offset)
? 0
: offset));
- PL_parser->copline = (line_t)(ps[(1) - (6)].val.ival);
- }
+ parser->copline = (line_t)(ps[(1) - (6)].val.ival);
+ ;}
break;
case 37:
#line 334 "perly.y"
- { (yyval.opval) = block_end((ps[(3) - (6)].val.ival), newWHENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)))); }
+ { (yyval.opval) = block_end((ps[(3) - (6)].val.ival), newWHENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)))); ;}
break;
case 38:
#line 336 "perly.y"
- { (yyval.opval) = newWHENOP(0, op_scope((ps[(2) - (2)].val.opval))); }
+ { (yyval.opval) = newWHENOP(0, op_scope((ps[(2) - (2)].val.opval))); ;}
break;
case 39:
(yyval.opval) = block_end((ps[(3) - (8)].val.ival),
newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
(ps[(4) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval), (ps[(6) - (8)].val.ival)));
- PL_parser->copline = (line_t)(ps[(1) - (8)].val.ival);
- }
+ parser->copline = (line_t)(ps[(1) - (8)].val.ival);
+ ;}
break;
case 40:
(yyval.opval) = block_end((ps[(3) - (8)].val.ival),
newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
(ps[(4) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval), (ps[(6) - (8)].val.ival)));
- PL_parser->copline = (line_t)(ps[(1) - (8)].val.ival);
- }
+ parser->copline = (line_t)(ps[(1) - (8)].val.ival);
+ ;}
break;
case 41:
-#line 353 "perly.y"
+#line 352 "perly.y"
+ { parser->expect = XTERM; ;}
+ break;
+
+ case 42:
+#line 354 "perly.y"
+ { parser->expect = XTERM; ;}
+ break;
+
+ case 43:
+#line 357 "perly.y"
{
- OP *initop = (ps[(4) - (11)].val.opval);
+ OP *initop = (ps[(4) - (13)].val.opval);
OP *forop = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
- scalar((ps[(6) - (11)].val.opval)), (ps[(11) - (11)].val.opval), (ps[(9) - (11)].val.opval), (ps[(8) - (11)].val.ival));
+ scalar((ps[(7) - (13)].val.opval)), (ps[(13) - (13)].val.opval), (ps[(11) - (13)].val.opval), (ps[(10) - (13)].val.ival));
if (initop) {
forop = op_prepend_elem(OP_LINESEQ, initop,
op_append_elem(OP_LINESEQ,
newOP(OP_UNSTACK, OPf_SPECIAL),
forop));
}
- (yyval.opval) = block_end((ps[(3) - (11)].val.ival), forop);
- PL_parser->copline = (line_t)(ps[(1) - (11)].val.ival);
- }
+ (yyval.opval) = block_end((ps[(3) - (13)].val.ival), forop);
+ parser->copline = (line_t)(ps[(1) - (13)].val.ival);
+ ;}
break;
- case 42:
-#line 367 "perly.y"
+ case 44:
+#line 371 "perly.y"
{
(yyval.opval) = block_end((ps[(3) - (9)].val.ival), newFOROP(0, (ps[(4) - (9)].val.opval), (ps[(6) - (9)].val.opval), (ps[(8) - (9)].val.opval), (ps[(9) - (9)].val.opval)));
- PL_parser->copline = (line_t)(ps[(1) - (9)].val.ival);
- }
+ parser->copline = (line_t)(ps[(1) - (9)].val.ival);
+ ;}
break;
- case 43:
-#line 372 "perly.y"
+ case 45:
+#line 376 "perly.y"
{
(yyval.opval) = block_end((ps[(4) - (8)].val.ival), newFOROP(0,
op_lvalue((ps[(2) - (8)].val.opval), OP_ENTERLOOP), (ps[(5) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval)));
- PL_parser->copline = (line_t)(ps[(1) - (8)].val.ival);
- }
+ parser->copline = (line_t)(ps[(1) - (8)].val.ival);
+ ;}
break;
- case 44:
-#line 378 "perly.y"
+ case 46:
+#line 382 "perly.y"
{
(yyval.opval) = block_end((ps[(3) - (7)].val.ival),
newFOROP(0, (OP*)NULL, (ps[(4) - (7)].val.opval), (ps[(6) - (7)].val.opval), (ps[(7) - (7)].val.opval)));
- PL_parser->copline = (line_t)(ps[(1) - (7)].val.ival);
- }
+ parser->copline = (line_t)(ps[(1) - (7)].val.ival);
+ ;}
break;
- case 45:
-#line 384 "perly.y"
+ case 47:
+#line 388 "perly.y"
{
/* a block is a loop that happens once */
(yyval.opval) = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
(OP*)NULL, (ps[(1) - (2)].val.opval), (ps[(2) - (2)].val.opval), 0);
- }
+ ;}
break;
- case 46:
-#line 390 "perly.y"
+ case 48:
+#line 394 "perly.y"
{
package((ps[(3) - (5)].val.opval));
if ((ps[(2) - (5)].val.opval)) {
package_version((ps[(2) - (5)].val.opval));
}
- }
+ ;}
break;
- case 47:
-#line 397 "perly.y"
+ case 49:
+#line 401 "perly.y"
{
/* a block is a loop that happens once */
(yyval.opval) = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
(OP*)NULL, block_end((ps[(5) - (8)].val.ival), (ps[(7) - (8)].val.opval)), (OP*)NULL, 0);
- if (PL_parser->copline > (line_t)(ps[(4) - (8)].val.ival))
- PL_parser->copline = (line_t)(ps[(4) - (8)].val.ival);
- }
+ if (parser->copline > (line_t)(ps[(4) - (8)].val.ival))
+ parser->copline = (line_t)(ps[(4) - (8)].val.ival);
+ ;}
break;
- case 48:
-#line 405 "perly.y"
+ case 50:
+#line 409 "perly.y"
{
- PL_parser->expect = XSTATE;
(yyval.opval) = (ps[(1) - (2)].val.opval);
- }
+ ;}
break;
- case 49:
-#line 410 "perly.y"
+ case 51:
+#line 413 "perly.y"
{
- PL_parser->expect = XSTATE;
(yyval.opval) = (OP*)NULL;
- PL_parser->copline = NOLINE;
- }
+ parser->copline = NOLINE;
+ ;}
break;
- case 50:
-#line 419 "perly.y"
+ case 52:
+#line 421 "perly.y"
{ OP *list;
if ((ps[(2) - (2)].val.opval)) {
OP *term = (ps[(2) - (2)].val.opval);
else {
list = (ps[(1) - (2)].val.opval);
}
- if (PL_parser->copline == NOLINE)
- PL_parser->copline = CopLINE(PL_curcop)-1;
- else PL_parser->copline--;
+ if (parser->copline == NOLINE)
+ parser->copline = CopLINE(PL_curcop)-1;
+ else parser->copline--;
(yyval.opval) = newSTATEOP(0, NULL,
convert(OP_FORMLINE, 0, list));
- }
- break;
-
- case 51:
-#line 436 "perly.y"
- { (yyval.opval) = NULL; }
- break;
-
- case 52:
-#line 438 "perly.y"
- { (yyval.opval) = op_unscope((ps[(2) - (3)].val.opval)); }
+ ;}
break;
case 53:
-#line 443 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+#line 438 "perly.y"
+ { (yyval.opval) = NULL; ;}
break;
case 54:
-#line 445 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 440 "perly.y"
+ { (yyval.opval) = op_unscope((ps[(2) - (3)].val.opval)); ;}
break;
case 55:
-#line 447 "perly.y"
- { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); }
+#line 445 "perly.y"
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 56:
-#line 449 "perly.y"
- { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); }
+#line 447 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 57:
-#line 451 "perly.y"
- { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[(3) - (3)].val.opval)), (ps[(1) - (3)].val.opval)); }
+#line 449 "perly.y"
+ { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;}
break;
case 58:
-#line 453 "perly.y"
- { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); }
+#line 451 "perly.y"
+ { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;}
break;
case 59:
-#line 455 "perly.y"
- { (yyval.opval) = newFOROP(0, (OP*)NULL, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval), (OP*)NULL);
- PL_parser->copline = (line_t)(ps[(2) - (3)].val.ival); }
+#line 453 "perly.y"
+ { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[(3) - (3)].val.opval)), (ps[(1) - (3)].val.opval)); ;}
break;
case 60:
-#line 458 "perly.y"
- { (yyval.opval) = newWHENOP((ps[(3) - (3)].val.opval), op_scope((ps[(1) - (3)].val.opval))); }
+#line 455 "perly.y"
+ { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;}
break;
case 61:
-#line 463 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+#line 457 "perly.y"
+ { (yyval.opval) = newFOROP(0, (OP*)NULL, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval), (OP*)NULL);
+ parser->copline = (line_t)(ps[(2) - (3)].val.ival); ;}
break;
case 62:
+#line 460 "perly.y"
+ { (yyval.opval) = newWHENOP((ps[(3) - (3)].val.opval), op_scope((ps[(1) - (3)].val.opval))); ;}
+ break;
+
+ case 63:
#line 465 "perly.y"
+ { (yyval.opval) = (OP*)NULL; ;}
+ break;
+
+ case 64:
+#line 467 "perly.y"
{
((ps[(2) - (2)].val.opval))->op_flags |= OPf_PARENS;
(yyval.opval) = op_scope((ps[(2) - (2)].val.opval));
- }
+ ;}
break;
- case 63:
-#line 470 "perly.y"
- { PL_parser->copline = (line_t)(ps[(1) - (6)].val.ival);
+ case 65:
+#line 472 "perly.y"
+ { parser->copline = (line_t)(ps[(1) - (6)].val.ival);
(yyval.opval) = newCONDOP(0,
newSTATEOP(OPf_SPECIAL,NULL,(ps[(3) - (6)].val.opval)),
op_scope((ps[(5) - (6)].val.opval)), (ps[(6) - (6)].val.opval));
PL_hints |= HINT_BLOCK_SCOPE;
- }
+ ;}
break;
- case 64:
-#line 480 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ case 66:
+#line 482 "perly.y"
+ { (yyval.opval) = (OP*)NULL; ;}
break;
- case 65:
-#line 482 "perly.y"
- { (yyval.opval) = op_scope((ps[(2) - (2)].val.opval)); }
+ case 67:
+#line 484 "perly.y"
+ { (yyval.opval) = op_scope((ps[(2) - (2)].val.opval)); ;}
break;
- case 66:
-#line 487 "perly.y"
+ case 68:
+#line 489 "perly.y"
{ (yyval.ival) = (PL_min_intro_pending &&
PL_max_intro_pending >= PL_min_intro_pending);
- intro_my(); }
- break;
-
- case 67:
-#line 493 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ intro_my(); ;}
break;
case 69:
-#line 499 "perly.y"
- { YYSTYPE tmplval;
- (void)scan_num("1", &tmplval);
- (yyval.opval) = tmplval.opval; }
+#line 495 "perly.y"
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 71:
-#line 507 "perly.y"
- { (yyval.opval) = invert(scalar((ps[(1) - (1)].val.opval))); }
- break;
-
- case 72:
-#line 512 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); }
+#line 501 "perly.y"
+ { YYSTYPE tmplval;
+ (void)scan_num("1", &tmplval);
+ (yyval.opval) = tmplval.opval; ;}
break;
case 73:
-#line 516 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); }
+#line 509 "perly.y"
+ { (yyval.opval) = invert(scalar((ps[(1) - (1)].val.opval))); ;}
break;
case 74:
-#line 520 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); }
+#line 514 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;}
break;
case 75:
-#line 523 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 518 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;}
break;
case 76:
-#line 524 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+#line 522 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;}
break;
case 77:
-#line 528 "perly.y"
- { (yyval.ival) = start_subparse(FALSE, 0);
- SAVEFREESV(PL_compcv); }
+#line 525 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 78:
-#line 534 "perly.y"
- { (yyval.ival) = start_subparse(FALSE, CVf_ANON);
- SAVEFREESV(PL_compcv); }
+#line 526 "perly.y"
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 79:
-#line 539 "perly.y"
- { (yyval.ival) = start_subparse(TRUE, 0);
- SAVEFREESV(PL_compcv); }
+#line 530 "perly.y"
+ { (yyval.ival) = start_subparse(FALSE, 0);
+ SAVEFREESV(PL_compcv); ;}
break;
- case 82:
-#line 550 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ case 80:
+#line 536 "perly.y"
+ { (yyval.ival) = start_subparse(FALSE, CVf_ANON);
+ SAVEFREESV(PL_compcv); ;}
break;
- case 84:
-#line 556 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+ case 81:
+#line 541 "perly.y"
+ { (yyval.ival) = start_subparse(TRUE, 0);
+ SAVEFREESV(PL_compcv); ;}
break;
- case 85:
-#line 558 "perly.y"
- { (yyval.opval) = (ps[(2) - (2)].val.opval); }
+ case 84:
+#line 552 "perly.y"
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 86:
-#line 560 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+#line 558 "perly.y"
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 87:
-#line 565 "perly.y"
- { (yyval.opval) = (ps[(2) - (2)].val.opval); }
+#line 560 "perly.y"
+ { (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
break;
case 88:
-#line 567 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+#line 562 "perly.y"
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 89:
-#line 571 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+#line 567 "perly.y"
+ { (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
break;
case 90:
+#line 569 "perly.y"
+ { (yyval.opval) = (OP*)NULL; ;}
+ break;
+
+ case 91:
#line 573 "perly.y"
+ { (yyval.opval) = (OP*)NULL; ;}
+ break;
+
+ case 92:
+#line 575 "perly.y"
{
if (!FEATURE_SIGNATURES_IS_ENABLED)
Perl_croak(aTHX_ "Experimental "
packWARN(WARN_EXPERIMENTAL__SIGNATURES),
"The signatures feature is experimental");
(yyval.opval) = parse_subsignature();
- }
+ ;}
break;
- case 91:
-#line 583 "perly.y"
+ case 93:
+#line 585 "perly.y"
{
(yyval.opval) = op_append_list(OP_LINESEQ, (ps[(2) - (3)].val.opval),
newSTATEOP(0, NULL, sawparens(newNULLLIST())));
- PL_parser->expect = XBLOCK;
- }
+ parser->expect = XBLOCK;
+ ;}
break;
- case 92:
-#line 592 "perly.y"
+ case 94:
+#line 594 "perly.y"
{
- if (PL_parser->copline > (line_t)(ps[(3) - (5)].val.ival))
- PL_parser->copline = (line_t)(ps[(3) - (5)].val.ival);
+ if (parser->copline > (line_t)(ps[(3) - (5)].val.ival))
+ parser->copline = (line_t)(ps[(3) - (5)].val.ival);
(yyval.opval) = block_end((ps[(1) - (5)].val.ival),
op_append_list(OP_LINESEQ, (ps[(2) - (5)].val.opval), (ps[(4) - (5)].val.opval)));
- }
+ ;}
break;
- case 93:
-#line 601 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 95:
+#line 603 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 94:
-#line 602 "perly.y"
- { (yyval.opval) = (OP*)NULL;
- PL_parser->expect = XSTATE;
- }
+ case 96:
+#line 604 "perly.y"
+ { (yyval.opval) = (OP*)NULL; ;}
break;
- case 95:
+ case 97:
#line 609 "perly.y"
- { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); }
+ { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
- case 96:
+ case 98:
#line 611 "perly.y"
- { (yyval.opval) = newLOGOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); }
+ { (yyval.opval) = newLOGOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
- case 97:
+ case 99:
#line 613 "perly.y"
- { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); }
+ { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
- case 99:
+ case 101:
#line 619 "perly.y"
- { (yyval.opval) = (ps[(1) - (2)].val.opval); }
+ { (yyval.opval) = (ps[(1) - (2)].val.opval); ;}
break;
- case 100:
+ case 102:
#line 621 "perly.y"
{
OP* term = (ps[(3) - (3)].val.opval);
(yyval.opval) = op_append_elem(OP_LIST, (ps[(1) - (3)].val.opval), term);
- }
+ ;}
break;
- case 102:
+ case 104:
#line 630 "perly.y"
{ (yyval.opval) = convert((ps[(1) - (3)].val.ival), OPf_STACKED,
op_prepend_elem(OP_LIST, newGVREF((ps[(1) - (3)].val.ival),(ps[(2) - (3)].val.opval)), (ps[(3) - (3)].val.opval)) );
- }
+ ;}
break;
- case 103:
+ case 105:
#line 634 "perly.y"
{ (yyval.opval) = convert((ps[(1) - (5)].val.ival), OPf_STACKED,
op_prepend_elem(OP_LIST, newGVREF((ps[(1) - (5)].val.ival),(ps[(3) - (5)].val.opval)), (ps[(4) - (5)].val.opval)) );
- }
+ ;}
break;
- case 104:
+ case 106:
#line 638 "perly.y"
{ (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, scalar((ps[(1) - (6)].val.opval)), (ps[(5) - (6)].val.opval)),
newUNOP(OP_METHOD, 0, (ps[(3) - (6)].val.opval))));
- }
+ ;}
break;
- case 105:
+ case 107:
#line 644 "perly.y"
{ (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, scalar((ps[(1) - (3)].val.opval)),
newUNOP(OP_METHOD, 0, (ps[(3) - (3)].val.opval))));
- }
+ ;}
break;
- case 106:
+ case 108:
#line 649 "perly.y"
{ (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, (ps[(2) - (3)].val.opval), (ps[(3) - (3)].val.opval)),
newUNOP(OP_METHOD, 0, (ps[(1) - (3)].val.opval))));
- }
+ ;}
break;
- case 107:
+ case 109:
#line 655 "perly.y"
{ (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, (ps[(2) - (5)].val.opval), (ps[(4) - (5)].val.opval)),
newUNOP(OP_METHOD, 0, (ps[(1) - (5)].val.opval))));
- }
+ ;}
break;
- case 108:
+ case 110:
#line 661 "perly.y"
- { (yyval.opval) = convert((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); }
+ { (yyval.opval) = convert((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;}
break;
- case 109:
+ case 111:
#line 663 "perly.y"
- { (yyval.opval) = convert((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); }
+ { (yyval.opval) = convert((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); ;}
break;
- case 110:
+ case 112:
#line 665 "perly.y"
{ SvREFCNT_inc_simple_void(PL_compcv);
- (yyval.opval) = newANONATTRSUB((ps[(2) - (3)].val.ival), 0, (OP*)NULL, (ps[(3) - (3)].val.opval)); }
+ (yyval.opval) = newANONATTRSUB((ps[(2) - (3)].val.ival), 0, (OP*)NULL, (ps[(3) - (3)].val.opval)); ;}
break;
- case 111:
+ case 113:
#line 668 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)), (ps[(1) - (5)].val.opval)));
- }
+ ;}
break;
- case 114:
+ case 116:
#line 683 "perly.y"
- { (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[(1) - (5)].val.opval), scalar((ps[(3) - (5)].val.opval)));
- PL_parser->expect = XOPERATOR;
- }
+ { (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[(1) - (5)].val.opval), scalar((ps[(3) - (5)].val.opval))); ;}
break;
- case 115:
-#line 687 "perly.y"
+ case 117:
+#line 685 "perly.y"
{ (yyval.opval) = newBINOP(OP_AELEM, 0, oopsAV((ps[(1) - (4)].val.opval)), scalar((ps[(3) - (4)].val.opval)));
- }
+ ;}
break;
- case 116:
-#line 690 "perly.y"
+ case 118:
+#line 688 "perly.y"
{ (yyval.opval) = newBINOP(OP_AELEM, 0,
ref(newAVREF((ps[(1) - (5)].val.opval)),OP_RV2AV),
scalar((ps[(4) - (5)].val.opval)));
- }
+ ;}
break;
- case 117:
-#line 695 "perly.y"
+ case 119:
+#line 693 "perly.y"
{ (yyval.opval) = newBINOP(OP_AELEM, 0,
ref(newAVREF((ps[(1) - (4)].val.opval)),OP_RV2AV),
scalar((ps[(3) - (4)].val.opval)));
- }
+ ;}
break;
- case 118:
-#line 700 "perly.y"
+ case 120:
+#line 698 "perly.y"
{ (yyval.opval) = newBINOP(OP_HELEM, 0, oopsHV((ps[(1) - (5)].val.opval)), jmaybe((ps[(3) - (5)].val.opval)));
- PL_parser->expect = XOPERATOR;
- }
+ ;}
break;
- case 119:
-#line 704 "perly.y"
+ case 121:
+#line 701 "perly.y"
{ (yyval.opval) = newBINOP(OP_HELEM, 0,
ref(newHVREF((ps[(1) - (6)].val.opval)),OP_RV2HV),
- jmaybe((ps[(4) - (6)].val.opval)));
- PL_parser->expect = XOPERATOR;
- }
+ jmaybe((ps[(4) - (6)].val.opval))); ;}
break;
- case 120:
-#line 710 "perly.y"
+ case 122:
+#line 705 "perly.y"
{ (yyval.opval) = newBINOP(OP_HELEM, 0,
ref(newHVREF((ps[(1) - (5)].val.opval)),OP_RV2HV),
- jmaybe((ps[(3) - (5)].val.opval)));
- PL_parser->expect = XOPERATOR;
- }
- break;
-
- case 121:
-#line 716 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- newCVREF(0, scalar((ps[(1) - (4)].val.opval)))); }
- break;
-
- case 122:
-#line 719 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, (ps[(4) - (5)].val.opval),
- newCVREF(0, scalar((ps[(1) - (5)].val.opval))))); }
+ jmaybe((ps[(3) - (5)].val.opval))); ;}
break;
case 123:
-#line 724 "perly.y"
+#line 709 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, (ps[(3) - (4)].val.opval),
- newCVREF(0, scalar((ps[(1) - (4)].val.opval))))); }
+ newCVREF(0, scalar((ps[(1) - (4)].val.opval)))); ;}
break;
case 124:
-#line 728 "perly.y"
+#line 712 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- newCVREF(0, scalar((ps[(1) - (3)].val.opval)))); }
+ op_append_elem(OP_LIST, (ps[(4) - (5)].val.opval),
+ newCVREF(0, scalar((ps[(1) - (5)].val.opval))))); ;}
break;
case 125:
-#line 731 "perly.y"
- { (yyval.opval) = newSLICEOP(0, (ps[(5) - (6)].val.opval), (ps[(2) - (6)].val.opval)); }
+#line 717 "perly.y"
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ op_append_elem(OP_LIST, (ps[(3) - (4)].val.opval),
+ newCVREF(0, scalar((ps[(1) - (4)].val.opval))))); ;}
break;
case 126:
-#line 733 "perly.y"
- { (yyval.opval) = newSLICEOP(0, (ps[(3) - (4)].val.opval), (ps[(1) - (4)].val.opval)); }
+#line 721 "perly.y"
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ newCVREF(0, scalar((ps[(1) - (3)].val.opval)))); ;}
break;
case 127:
-#line 735 "perly.y"
- { (yyval.opval) = newSLICEOP(0, (ps[(4) - (5)].val.opval), (OP*)NULL); }
+#line 724 "perly.y"
+ { (yyval.opval) = newSLICEOP(0, (ps[(5) - (6)].val.opval), (ps[(2) - (6)].val.opval)); ;}
break;
case 128:
-#line 740 "perly.y"
- { (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[(1) - (3)].val.opval), (ps[(2) - (3)].val.ival), (ps[(3) - (3)].val.opval)); }
+#line 726 "perly.y"
+ { (yyval.opval) = newSLICEOP(0, (ps[(3) - (4)].val.opval), (ps[(1) - (4)].val.opval)); ;}
break;
case 129:
-#line 742 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+#line 728 "perly.y"
+ { (yyval.opval) = newSLICEOP(0, (ps[(4) - (5)].val.opval), (OP*)NULL); ;}
break;
case 130:
-#line 744 "perly.y"
- { if ((ps[(2) - (3)].val.ival) != OP_REPEAT)
- scalar((ps[(1) - (3)].val.opval));
- (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), scalar((ps[(3) - (3)].val.opval)));
- }
+#line 733 "perly.y"
+ { (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[(1) - (3)].val.opval), (ps[(2) - (3)].val.ival), (ps[(3) - (3)].val.opval)); ;}
break;
case 131:
-#line 749 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+#line 735 "perly.y"
+ { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 132:
-#line 751 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+#line 737 "perly.y"
+ { if ((ps[(2) - (3)].val.ival) != OP_REPEAT)
+ scalar((ps[(1) - (3)].val.opval));
+ (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), scalar((ps[(3) - (3)].val.opval)));
+ ;}
break;
case 133:
-#line 753 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+#line 742 "perly.y"
+ { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 134:
-#line 755 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+#line 744 "perly.y"
+ { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 135:
-#line 757 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+#line 746 "perly.y"
+ { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 136:
-#line 759 "perly.y"
- { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+#line 748 "perly.y"
+ { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 137:
-#line 761 "perly.y"
- { (yyval.opval) = newRANGE((ps[(2) - (3)].val.ival), scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); }
+#line 750 "perly.y"
+ { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 138:
-#line 763 "perly.y"
- { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); }
+#line 752 "perly.y"
+ { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 139:
-#line 765 "perly.y"
- { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); }
+#line 754 "perly.y"
+ { (yyval.opval) = newRANGE((ps[(2) - (3)].val.ival), scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 140:
-#line 767 "perly.y"
- { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); }
+#line 756 "perly.y"
+ { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 141:
-#line 769 "perly.y"
- { (yyval.opval) = bind_match((ps[(2) - (3)].val.ival), (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); }
+#line 758 "perly.y"
+ { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 142:
-#line 774 "perly.y"
- { (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[(2) - (2)].val.opval))); }
+#line 760 "perly.y"
+ { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 143:
-#line 776 "perly.y"
- { (yyval.opval) = (ps[(2) - (2)].val.opval); }
+#line 762 "perly.y"
+ { (yyval.opval) = bind_match((ps[(2) - (3)].val.ival), (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 144:
-#line 779 "perly.y"
- { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); }
+#line 767 "perly.y"
+ { (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[(2) - (2)].val.opval))); ;}
break;
case 145:
-#line 781 "perly.y"
- { (yyval.opval) = newUNOP(OP_COMPLEMENT, 0, scalar((ps[(2) - (2)].val.opval))); }
+#line 769 "perly.y"
+ { (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
break;
case 146:
-#line 783 "perly.y"
- { (yyval.opval) = newUNOP(OP_POSTINC, 0,
- op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTINC)); }
+#line 772 "perly.y"
+ { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); ;}
break;
case 147:
-#line 786 "perly.y"
- { (yyval.opval) = newUNOP(OP_POSTDEC, 0,
- op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTDEC));}
+#line 774 "perly.y"
+ { (yyval.opval) = newUNOP(OP_COMPLEMENT, 0, scalar((ps[(2) - (2)].val.opval))); ;}
break;
case 148:
-#line 789 "perly.y"
+#line 776 "perly.y"
+ { (yyval.opval) = newUNOP(OP_POSTINC, 0,
+ op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTINC)); ;}
+ break;
+
+ case 149:
+#line 779 "perly.y"
+ { (yyval.opval) = newUNOP(OP_POSTDEC, 0,
+ op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTDEC));;}
+ break;
+
+ case 150:
+#line 782 "perly.y"
{ (yyval.opval) = convert(OP_JOIN, 0,
op_append_elem(
OP_LIST,
)),
(ps[(1) - (2)].val.opval)
));
- }
- break;
-
- case 149:
-#line 800 "perly.y"
- { (yyval.opval) = newUNOP(OP_PREINC, 0,
- op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREINC)); }
- break;
-
- case 150:
-#line 803 "perly.y"
- { (yyval.opval) = newUNOP(OP_PREDEC, 0,
- op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREDEC)); }
+ ;}
break;
case 151:
-#line 810 "perly.y"
- { (yyval.opval) = newANONLIST((ps[(2) - (3)].val.opval)); }
+#line 793 "perly.y"
+ { (yyval.opval) = newUNOP(OP_PREINC, 0,
+ op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREINC)); ;}
break;
case 152:
-#line 812 "perly.y"
- { (yyval.opval) = newANONLIST((OP*)NULL);}
+#line 796 "perly.y"
+ { (yyval.opval) = newUNOP(OP_PREDEC, 0,
+ op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREDEC)); ;}
break;
case 153:
-#line 814 "perly.y"
- { (yyval.opval) = newANONHASH((ps[(2) - (4)].val.opval)); }
+#line 803 "perly.y"
+ { (yyval.opval) = newANONLIST((ps[(2) - (3)].val.opval)); ;}
break;
case 154:
-#line 816 "perly.y"
- { (yyval.opval) = newANONHASH((OP*)NULL); }
+#line 805 "perly.y"
+ { (yyval.opval) = newANONLIST((OP*)NULL);;}
break;
case 155:
-#line 818 "perly.y"
- { SvREFCNT_inc_simple_void(PL_compcv);
- (yyval.opval) = newANONATTRSUB((ps[(2) - (5)].val.ival), (ps[(3) - (5)].val.opval), (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)); }
+#line 807 "perly.y"
+ { (yyval.opval) = newANONHASH((ps[(2) - (4)].val.opval)); ;}
break;
case 156:
-#line 825 "perly.y"
- { (yyval.opval) = dofile((ps[(2) - (2)].val.opval), (ps[(1) - (2)].val.ival));}
+#line 809 "perly.y"
+ { (yyval.opval) = newANONHASH((OP*)NULL); ;}
break;
case 157:
-#line 827 "perly.y"
- { (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[(2) - (2)].val.opval)));}
+#line 811 "perly.y"
+ { SvREFCNT_inc_simple_void(PL_compcv);
+ (yyval.opval) = newANONATTRSUB((ps[(2) - (5)].val.ival), (ps[(3) - (5)].val.opval), (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)); ;}
break;
- case 162:
-#line 835 "perly.y"
- { (yyval.opval) = newCONDOP(0, (ps[(1) - (5)].val.opval), (ps[(3) - (5)].val.opval), (ps[(5) - (5)].val.opval)); }
+ case 158:
+#line 818 "perly.y"
+ { (yyval.opval) = dofile((ps[(2) - (2)].val.opval), (ps[(1) - (2)].val.ival));;}
break;
- case 163:
-#line 837 "perly.y"
- { (yyval.opval) = newUNOP(OP_REFGEN, 0, op_lvalue((ps[(2) - (2)].val.opval),OP_REFGEN)); }
+ case 159:
+#line 820 "perly.y"
+ { (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[(2) - (2)].val.opval)));;}
break;
case 164:
-#line 839 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 828 "perly.y"
+ { (yyval.opval) = newCONDOP(0, (ps[(1) - (5)].val.opval), (ps[(3) - (5)].val.opval), (ps[(5) - (5)].val.opval)); ;}
break;
case 165:
-#line 841 "perly.y"
- { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); }
+#line 830 "perly.y"
+ { (yyval.opval) = newUNOP(OP_REFGEN, 0, op_lvalue((ps[(2) - (2)].val.opval),OP_REFGEN)); ;}
break;
case 166:
-#line 843 "perly.y"
- { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); }
+#line 832 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 167:
-#line 845 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 834 "perly.y"
+ { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); ;}
break;
case 168:
-#line 847 "perly.y"
- { (yyval.opval) = sawparens(newNULLLIST()); }
+#line 836 "perly.y"
+ { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); ;}
break;
case 169:
-#line 849 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 838 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 170:
-#line 851 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 840 "perly.y"
+ { (yyval.opval) = sawparens(newNULLLIST()); ;}
break;
case 171:
-#line 853 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 842 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 172:
-#line 855 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 844 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 173:
-#line 857 "perly.y"
- { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[(1) - (1)].val.opval), OP_AV2ARYLEN));}
+#line 846 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 174:
-#line 859 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 848 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 175:
-#line 861 "perly.y"
+#line 850 "perly.y"
+ { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[(1) - (1)].val.opval), OP_AV2ARYLEN));;}
+ break;
+
+ case 176:
+#line 852 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+ break;
+
+ case 177:
+#line 854 "perly.y"
{ (yyval.opval) = op_prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_ASLICE, 0,
if ((yyval.opval) && (ps[(1) - (4)].val.opval))
(yyval.opval)->op_private |=
(ps[(1) - (4)].val.opval)->op_private & OPpSLICEWARNING;
- }
+ ;}
break;
- case 176:
-#line 871 "perly.y"
+ case 178:
+#line 864 "perly.y"
{ (yyval.opval) = op_prepend_elem(OP_KVASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_KVASLICE, 0,
if ((yyval.opval) && (ps[(1) - (4)].val.opval))
(yyval.opval)->op_private |=
(ps[(1) - (4)].val.opval)->op_private & OPpSLICEWARNING;
- }
+ ;}
break;
- case 177:
-#line 881 "perly.y"
+ case 179:
+#line 874 "perly.y"
{ (yyval.opval) = op_prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
if ((yyval.opval) && (ps[(1) - (5)].val.opval))
(yyval.opval)->op_private |=
(ps[(1) - (5)].val.opval)->op_private & OPpSLICEWARNING;
- PL_parser->expect = XOPERATOR;
- }
+ ;}
break;
- case 178:
-#line 892 "perly.y"
+ case 180:
+#line 884 "perly.y"
{ (yyval.opval) = op_prepend_elem(OP_KVHSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_KVHSLICE, 0,
if ((yyval.opval) && (ps[(1) - (5)].val.opval))
(yyval.opval)->op_private |=
(ps[(1) - (5)].val.opval)->op_private & OPpSLICEWARNING;
- PL_parser->expect = XOPERATOR;
- }
+ ;}
break;
- case 179:
-#line 903 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+ case 181:
+#line 894 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
- case 180:
-#line 905 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[(1) - (1)].val.opval))); }
+ case 182:
+#line 896 "perly.y"
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[(1) - (1)].val.opval))); ;}
break;
- case 181:
-#line 907 "perly.y"
+ case 183:
+#line 898 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (3)].val.opval)));
- }
+ ;}
break;
- case 182:
-#line 910 "perly.y"
+ case 184:
+#line 901 "perly.y"
{
(yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, (ps[(3) - (4)].val.opval), scalar((ps[(1) - (4)].val.opval))));
- }
+ ;}
break;
- case 183:
-#line 915 "perly.y"
+ case 185:
+#line 906 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, (ps[(3) - (3)].val.opval), scalar((ps[(2) - (3)].val.opval))));
- }
- break;
-
- case 184:
-#line 919 "perly.y"
- { (yyval.opval) = newSVREF((ps[(1) - (4)].val.opval)); }
- break;
-
- case 185:
-#line 921 "perly.y"
- { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); }
+ ;}
break;
case 186:
-#line 923 "perly.y"
- { (yyval.opval) = newHVREF((ps[(1) - (4)].val.opval)); }
+#line 910 "perly.y"
+ { (yyval.opval) = newSVREF((ps[(1) - (4)].val.opval)); ;}
break;
case 187:
-#line 925 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, 0,
- scalar(newCVREF((ps[(3) - (4)].val.ival),(ps[(1) - (4)].val.opval)))); }
+#line 912 "perly.y"
+ { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); ;}
break;
case 188:
-#line 928 "perly.y"
- { (yyval.opval) = newGVREF(0,(ps[(1) - (4)].val.opval)); }
+#line 914 "perly.y"
+ { (yyval.opval) = newHVREF((ps[(1) - (4)].val.opval)); ;}
break;
case 189:
-#line 930 "perly.y"
- { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), OPf_SPECIAL);
- PL_hints |= HINT_BLOCK_SCOPE; }
+#line 916 "perly.y"
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, 0,
+ scalar(newCVREF((ps[(3) - (4)].val.ival),(ps[(1) - (4)].val.opval)))); ;}
break;
case 190:
-#line 933 "perly.y"
- { (yyval.opval) = newLOOPEX((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); }
+#line 919 "perly.y"
+ { (yyval.opval) = newGVREF(0,(ps[(1) - (4)].val.opval)); ;}
break;
case 191:
-#line 935 "perly.y"
- { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); }
+#line 921 "perly.y"
+ { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), OPf_SPECIAL);
+ PL_hints |= HINT_BLOCK_SCOPE; ;}
break;
case 192:
-#line 937 "perly.y"
- { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); }
+#line 924 "perly.y"
+ { (yyval.opval) = newLOOPEX((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); ;}
break;
case 193:
-#line 939 "perly.y"
- { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); }
+#line 926 "perly.y"
+ { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); ;}
break;
case 194:
-#line 941 "perly.y"
- { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); }
+#line 928 "perly.y"
+ { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); ;}
break;
case 195:
-#line 943 "perly.y"
- { (yyval.opval) = newOP(OP_REQUIRE, (ps[(1) - (1)].val.ival) ? OPf_SPECIAL : 0); }
+#line 930 "perly.y"
+ { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;}
break;
case 196:
-#line 945 "perly.y"
- { (yyval.opval) = newUNOP(OP_REQUIRE, (ps[(1) - (2)].val.ival) ? OPf_SPECIAL : 0, (ps[(2) - (2)].val.opval)); }
+#line 932 "perly.y"
+ { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;}
break;
case 197:
-#line 947 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); }
+#line 934 "perly.y"
+ { (yyval.opval) = newOP(OP_REQUIRE, (ps[(1) - (1)].val.ival) ? OPf_SPECIAL : 0); ;}
break;
case 198:
-#line 949 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, (ps[(2) - (2)].val.opval), scalar((ps[(1) - (2)].val.opval)))); }
+#line 936 "perly.y"
+ { (yyval.opval) = newUNOP(OP_REQUIRE, (ps[(1) - (2)].val.ival) ? OPf_SPECIAL : 0, (ps[(2) - (2)].val.opval)); ;}
break;
case 199:
-#line 952 "perly.y"
- { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); }
+#line 938 "perly.y"
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;}
break;
case 200:
-#line 954 "perly.y"
- { (yyval.opval) = newOP((ps[(1) - (3)].val.ival), 0);}
+#line 940 "perly.y"
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ op_append_elem(OP_LIST, (ps[(2) - (2)].val.opval), scalar((ps[(1) - (2)].val.opval)))); ;}
break;
case 201:
-#line 956 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 943 "perly.y"
+ { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); ;}
break;
case 202:
-#line 958 "perly.y"
- { (yyval.opval) = (ps[(1) - (3)].val.opval); }
+#line 945 "perly.y"
+ { (yyval.opval) = newOP((ps[(1) - (3)].val.ival), 0);;}
break;
case 203:
-#line 960 "perly.y"
- { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); }
+#line 947 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 204:
-#line 962 "perly.y"
- { (yyval.opval) = ((ps[(1) - (3)].val.ival) == OP_NOT)
- ? newUNOP((ps[(1) - (3)].val.ival), 0, newSVOP(OP_CONST, 0, newSViv(0)))
- : newOP((ps[(1) - (3)].val.ival), OPf_SPECIAL); }
+#line 949 "perly.y"
+ { (yyval.opval) = (ps[(1) - (3)].val.opval); ;}
break;
case 205:
-#line 966 "perly.y"
- { (yyval.opval) = newUNOP((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); }
+#line 951 "perly.y"
+ { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;}
break;
case 206:
-#line 968 "perly.y"
+#line 953 "perly.y"
+ { (yyval.opval) = ((ps[(1) - (3)].val.ival) == OP_NOT)
+ ? newUNOP((ps[(1) - (3)].val.ival), 0, newSVOP(OP_CONST, 0, newSViv(0)))
+ : newOP((ps[(1) - (3)].val.ival), OPf_SPECIAL); ;}
+ break;
+
+ case 207:
+#line 957 "perly.y"
+ { (yyval.opval) = newUNOP((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); ;}
+ break;
+
+ case 208:
+#line 959 "perly.y"
{
if ( (ps[(1) - (1)].val.opval)->op_type != OP_TRANS
&& (ps[(1) - (1)].val.opval)->op_type != OP_TRANSR
SAVEFREESV(PL_compcv);
} else
(yyval.ival) = 0;
- }
+ ;}
break;
- case 207:
-#line 979 "perly.y"
- { (yyval.opval) = pmruntime((ps[(1) - (5)].val.opval), (ps[(4) - (5)].val.opval), 1, (ps[(2) - (5)].val.ival)); }
+ case 209:
+#line 970 "perly.y"
+ { (yyval.opval) = pmruntime((ps[(1) - (5)].val.opval), (ps[(4) - (5)].val.opval), 1, (ps[(2) - (5)].val.ival)); ;}
break;
- case 210:
-#line 983 "perly.y"
+ case 212:
+#line 974 "perly.y"
{
(yyval.opval) = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
newSVOP(OP_CONST, 0, newSVpvs("Unimplemented")));
- }
- break;
-
- case 212:
-#line 992 "perly.y"
- { (yyval.opval) = my_attrs((ps[(2) - (3)].val.opval),(ps[(3) - (3)].val.opval)); }
- break;
-
- case 213:
-#line 994 "perly.y"
- { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); }
+ ;}
break;
case 214:
-#line 999 "perly.y"
- { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); }
+#line 983 "perly.y"
+ { (yyval.opval) = my_attrs((ps[(2) - (3)].val.opval),(ps[(3) - (3)].val.opval)); ;}
break;
case 215:
-#line 1001 "perly.y"
- { (yyval.opval) = sawparens(newNULLLIST()); }
+#line 985 "perly.y"
+ { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); ;}
break;
case 216:
-#line 1004 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 990 "perly.y"
+ { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); ;}
break;
case 217:
-#line 1006 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 992 "perly.y"
+ { (yyval.opval) = sawparens(newNULLLIST()); ;}
break;
case 218:
-#line 1008 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 995 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 219:
-#line 1013 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+#line 997 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 220:
-#line 1015 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 999 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 221:
-#line 1019 "perly.y"
- { (yyval.opval) = (OP*)NULL; }
+#line 1004 "perly.y"
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 222:
-#line 1021 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 1006 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 223:
-#line 1027 "perly.y"
- { PL_parser->in_my = 0; (yyval.opval) = my((ps[(1) - (1)].val.opval)); }
+#line 1010 "perly.y"
+ { (yyval.opval) = (OP*)NULL; ;}
break;
case 224:
-#line 1031 "perly.y"
- { (yyval.opval) = newCVREF((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); }
+#line 1012 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 225:
-#line 1035 "perly.y"
- { (yyval.opval) = newSVREF((ps[(2) - (2)].val.opval)); }
+#line 1018 "perly.y"
+ { parser->in_my = 0; (yyval.opval) = my((ps[(1) - (1)].val.opval)); ;}
break;
case 226:
-#line 1039 "perly.y"
- { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval));
- if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival);
- }
+#line 1022 "perly.y"
+ { (yyval.opval) = newCVREF((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); ;}
break;
case 227:
-#line 1045 "perly.y"
- { (yyval.opval) = newHVREF((ps[(2) - (2)].val.opval));
- if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival);
- }
+#line 1026 "perly.y"
+ { (yyval.opval) = newSVREF((ps[(2) - (2)].val.opval)); ;}
break;
case 228:
-#line 1051 "perly.y"
- { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); }
+#line 1030 "perly.y"
+ { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval));
+ if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival);
+ ;}
break;
case 229:
-#line 1053 "perly.y"
- { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); }
+#line 1036 "perly.y"
+ { (yyval.opval) = newHVREF((ps[(2) - (2)].val.opval));
+ if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival);
+ ;}
break;
case 230:
-#line 1057 "perly.y"
- { (yyval.opval) = newGVREF(0,(ps[(2) - (2)].val.opval)); }
+#line 1042 "perly.y"
+ { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); ;}
+ break;
+
+ case 231:
+#line 1044 "perly.y"
+ { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); ;}
break;
case 232:
-#line 1062 "perly.y"
- { (yyval.opval) = newAVREF((ps[(1) - (3)].val.opval)); }
+#line 1048 "perly.y"
+ { (yyval.opval) = newGVREF(0,(ps[(2) - (2)].val.opval)); ;}
break;
case 234:
-#line 1067 "perly.y"
- { (yyval.opval) = newHVREF((ps[(1) - (3)].val.opval)); }
+#line 1053 "perly.y"
+ { (yyval.opval) = newAVREF((ps[(1) - (3)].val.opval)); ;}
break;
case 236:
-#line 1072 "perly.y"
- { (yyval.opval) = newGVREF(0,(ps[(1) - (3)].val.opval)); }
- break;
-
- case 237:
-#line 1077 "perly.y"
- { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); }
+#line 1058 "perly.y"
+ { (yyval.opval) = newHVREF((ps[(1) - (3)].val.opval)); ;}
break;
case 238:
-#line 1079 "perly.y"
- { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); }
+#line 1063 "perly.y"
+ { (yyval.opval) = newGVREF(0,(ps[(1) - (3)].val.opval)); ;}
break;
case 239:
-#line 1081 "perly.y"
- { (yyval.opval) = op_scope((ps[(1) - (1)].val.opval)); }
+#line 1068 "perly.y"
+ { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;}
break;
case 240:
-#line 1084 "perly.y"
- { (yyval.opval) = (ps[(1) - (1)].val.opval); }
+#line 1070 "perly.y"
+ { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;}
+ break;
+
+ case 241:
+#line 1072 "perly.y"
+ { (yyval.opval) = op_scope((ps[(1) - (1)].val.opval)); ;}
break;
+ case 242:
+#line 1075 "perly.y"
+ { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
+ break;
+
+
+/* Line 1267 of yacc.c. */
+
default: break;
/* Generated from:
- * 7e6c275bbd1dbc800c205a8a8b0cd785e4859f94976ee7372149598471f16f81 perly.y
+ * 39b6174c4729deec2a6ee4698d7dcd6496acb0a8f063daf726d1f853d4dcb54e perly.y
* d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl
* ex: set ro: */
*/
#ifdef PERL_CORE
-/* A Bison parser, made by GNU Bison 2.7.12-4996. */
+/* A Bison parser, made by GNU Bison 2.3. */
-/* Bison interface for Yacc-like parsers in C
-
- Copyright (C) 1984, 1989-1990, 2000-2013 Free Software Foundation, Inc.
-
- This program is free software: you can redistribute it and/or modify
+/* Skeleton interface for Bison's Yacc-like parsers in C
+
+ Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
- the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
-
+ the Free Software Foundation; either version 2, 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, see <http://www.gnu.org/licenses/>. */
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ Boston, MA 02110-1301, USA. */
/* As a special exception, you may create a larger work that contains
part or all of the Bison parser skeleton and distribute that work
special exception, which will cause the skeleton and the resulting
Bison output files to be licensed under the GNU General Public
License without this special exception.
-
+
This special exception was added by the Free Software Foundation in
version 2.2 of Bison. */
-/* Enabling traces. */
-#ifndef YYDEBUG
-# define YYDEBUG 0
-#endif
-#if YYDEBUG
-extern int yydebug;
-#endif
-
/* Tokens. */
#ifndef YYTOKENTYPE
# define YYTOKENTYPE
ARROW = 337
};
#endif
-
/* Tokens. */
#define GRAMPROG 258
#define GRAMEXPR 259
#define ARROW 337
+
+
#ifdef PERL_IN_TOKE_C
static bool
S_is_opval_token(int type) {
#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED
typedef union YYSTYPE
{
-/* Line 2053 of yacc.c */
-
I32 ival; /* __DEFAULT__ (marker for regen_perly.pl;
must always be 1st union member) */
char *pval;
OP *opval;
GV *gvval;
-
-
-/* Line 2053 of yacc.c */
-} YYSTYPE;
-# define YYSTYPE_IS_TRIVIAL 1
+}
+/* Line 1529 of yacc.c. */
+ YYSTYPE;
# define yystype YYSTYPE /* obsolescent; will be withdrawn */
# define YYSTYPE_IS_DECLARED 1
+# define YYSTYPE_IS_TRIVIAL 1
#endif
-#ifdef YYPARSE_PARAM
-#if defined __STDC__ || defined __cplusplus
-int yyparse (void *YYPARSE_PARAM);
-#else
-int yyparse ();
-#endif
-#else /* ! YYPARSE_PARAM */
-#if defined __STDC__ || defined __cplusplus
-int yyparse (void);
-#else
-int yyparse ();
-#endif
-#endif /* ! YYPARSE_PARAM */
/* Generated from:
- * 7e6c275bbd1dbc800c205a8a8b0cd785e4859f94976ee7372149598471f16f81 perly.y
+ * 39b6174c4729deec2a6ee4698d7dcd6496acb0a8f063daf726d1f853d4dcb54e perly.y
* d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl
* ex: set ro: */
/* YYNTOKENS -- Number of terminals. */
#define YYNTOKENS 104
/* YYNNTS -- Number of nonterminals. */
-#define YYNNTS 72
+#define YYNNTS 74
/* YYNRULES -- Number of rules. */
-#define YYNRULES 240
+#define YYNRULES 242
/* YYNRULES -- Number of states. */
-#define YYNSTATES 474
+#define YYNSTATES 476
/* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */
#define YYUNDEFTOK 2
24, 25, 29, 30, 34, 39, 47, 48, 53, 54,
55, 58, 59, 62, 64, 66, 69, 72, 74, 79,
80, 88, 93, 94, 102, 110, 118, 125, 132, 135,
- 144, 153, 165, 175, 184, 192, 195, 196, 205, 208,
- 210, 213, 214, 218, 220, 222, 226, 230, 234, 238,
- 242, 246, 247, 250, 257, 258, 261, 262, 263, 265,
- 266, 268, 270, 272, 274, 276, 278, 279, 280, 281,
- 282, 284, 286, 287, 289, 290, 293, 295, 298, 300,
- 301, 302, 306, 312, 314, 316, 320, 324, 328, 330,
- 333, 337, 339, 343, 349, 356, 360, 364, 370, 373,
- 378, 379, 385, 387, 389, 395, 400, 406, 411, 417,
- 424, 430, 435, 441, 446, 450, 457, 462, 468, 472,
- 476, 480, 484, 488, 492, 496, 500, 504, 508, 512,
- 516, 520, 524, 527, 530, 533, 536, 539, 542, 545,
- 548, 551, 555, 558, 563, 567, 573, 576, 579, 581,
- 583, 585, 587, 593, 596, 598, 601, 605, 607, 610,
- 612, 614, 616, 618, 620, 622, 627, 632, 638, 644,
- 646, 648, 652, 657, 661, 666, 671, 676, 681, 686,
- 688, 691, 694, 696, 699, 702, 704, 707, 709, 712,
- 714, 718, 720, 724, 726, 730, 735, 736, 742, 744,
- 746, 748, 750, 754, 757, 761, 764, 766, 768, 770,
- 771, 773, 774, 776, 778, 781, 784, 787, 790, 793,
- 798, 801, 803, 807, 809, 813, 815, 819, 821, 823,
- 825
+ 144, 153, 154, 155, 169, 179, 188, 196, 199, 200,
+ 209, 212, 214, 217, 218, 222, 224, 226, 230, 234,
+ 238, 242, 246, 250, 251, 254, 261, 262, 265, 266,
+ 267, 269, 270, 272, 274, 276, 278, 280, 282, 283,
+ 284, 285, 286, 288, 290, 291, 293, 294, 297, 299,
+ 302, 304, 305, 306, 310, 316, 318, 320, 324, 328,
+ 332, 334, 337, 341, 343, 347, 353, 360, 364, 368,
+ 374, 377, 382, 383, 389, 391, 393, 399, 404, 410,
+ 415, 421, 428, 434, 439, 445, 450, 454, 461, 466,
+ 472, 476, 480, 484, 488, 492, 496, 500, 504, 508,
+ 512, 516, 520, 524, 528, 531, 534, 537, 540, 543,
+ 546, 549, 552, 555, 559, 562, 567, 571, 577, 580,
+ 583, 585, 587, 589, 591, 597, 600, 602, 605, 609,
+ 611, 614, 616, 618, 620, 622, 624, 626, 631, 636,
+ 642, 648, 650, 652, 656, 661, 665, 670, 675, 680,
+ 685, 690, 692, 695, 698, 700, 703, 706, 708, 711,
+ 713, 716, 718, 722, 724, 728, 730, 734, 739, 740,
+ 746, 748, 750, 752, 754, 758, 761, 765, 768, 770,
+ 772, 774, 775, 777, 778, 780, 782, 785, 788, 791,
+ 794, 797, 802, 805, 807, 811, 813, 817, 819, 823,
+ 825, 827, 829
};
/* YYRHS -- A `-1'-separated list of the rules' RHS. */
static const yytype_int16 yyrhs[] =
{
105, 0, -1, -1, 3, 106, 114, 117, -1, -1,
- 4, 107, 164, -1, -1, 5, 108, 112, -1, -1,
+ 4, 107, 166, -1, -1, 5, 108, 112, -1, -1,
6, 109, 121, -1, -1, 7, 110, 119, -1, -1,
8, 111, 117, -1, 9, 114, 117, 10, -1, 21,
114, 20, 74, 118, 20, 22, -1, -1, 9, 116,
117, 10, -1, -1, -1, 117, 119, -1, -1, 118,
- 125, -1, 121, -1, 120, -1, 36, 121, -1, 36,
- 120, -1, 35, -1, 37, 140, 137, 113, -1, -1,
- 38, 141, 138, 122, 142, 143, 148, -1, 40, 23,
- 23, 20, -1, -1, 41, 138, 123, 23, 23, 163,
- 20, -1, 44, 103, 114, 134, 102, 115, 128, -1,
- 45, 103, 114, 136, 102, 115, 128, -1, 50, 103,
- 114, 134, 102, 115, -1, 51, 103, 114, 134, 102,
- 115, -1, 52, 112, -1, 42, 103, 114, 132, 102,
- 130, 115, 129, -1, 43, 103, 114, 133, 102, 130,
- 115, 129, -1, 49, 103, 114, 135, 20, 132, 20,
- 130, 135, 102, 115, -1, 49, 70, 114, 165, 103,
- 134, 102, 115, 129, -1, 49, 167, 103, 114, 134,
- 102, 115, 129, -1, 49, 103, 114, 134, 102, 115,
- 129, -1, 112, 129, -1, -1, 40, 23, 23, 9,
- 114, 124, 117, 10, -1, 127, 20, -1, 20, -1,
- 26, 126, -1, -1, 73, 117, 74, -1, 1, -1,
- 149, -1, 149, 44, 149, -1, 149, 45, 149, -1,
- 149, 42, 149, -1, 149, 43, 133, -1, 149, 49,
- 149, -1, 149, 51, 149, -1, -1, 46, 115, -1,
- 47, 103, 134, 102, 115, 128, -1, -1, 48, 112,
- -1, -1, -1, 127, -1, -1, 149, -1, 149, -1,
- 149, -1, 131, -1, 133, -1, 23, -1, -1, -1,
- -1, -1, 23, -1, 28, -1, -1, 26, -1, -1,
- 72, 26, -1, 72, -1, 72, 26, -1, 72, -1,
- -1, -1, 103, 146, 102, -1, 114, 145, 9, 117,
- 10, -1, 147, -1, 20, -1, 149, 78, 149, -1,
- 149, 77, 149, -1, 149, 76, 149, -1, 150, -1,
- 150, 80, -1, 150, 80, 159, -1, 159, -1, 60,
- 175, 150, -1, 58, 103, 175, 149, 102, -1, 159,
- 101, 153, 103, 164, 102, -1, 159, 101, 153, -1,
- 24, 175, 163, -1, 25, 175, 103, 164, 102, -1,
- 60, 163, -1, 58, 103, 164, 102, -1, -1, 33,
- 139, 112, 152, 163, -1, 24, -1, 167, -1, 174,
- 9, 149, 20, 10, -1, 167, 11, 149, 12, -1,
- 159, 101, 11, 149, 12, -1, 154, 11, 149, 12,
- -1, 167, 9, 149, 20, 10, -1, 159, 101, 9,
- 149, 20, 10, -1, 154, 9, 149, 20, 10, -1,
- 159, 101, 103, 102, -1, 159, 101, 103, 149, 102,
- -1, 154, 103, 149, 102, -1, 154, 103, 102, -1,
- 103, 149, 102, 11, 149, 12, -1, 29, 11, 149,
- 12, -1, 103, 102, 11, 149, 12, -1, 159, 81,
- 159, -1, 159, 95, 159, -1, 159, 63, 159, -1,
- 159, 64, 159, -1, 159, 89, 159, -1, 159, 61,
- 159, -1, 159, 62, 159, -1, 159, 88, 159, -1,
- 159, 87, 159, -1, 159, 54, 159, -1, 159, 86,
- 159, -1, 159, 85, 159, -1, 159, 84, 159, -1,
- 159, 90, 159, -1, 13, 159, -1, 14, 159, -1,
- 91, 159, -1, 92, 159, -1, 159, 98, -1, 159,
- 97, -1, 159, 96, -1, 100, 159, -1, 99, 159,
- -1, 11, 149, 12, -1, 11, 12, -1, 67, 149,
- 20, 10, -1, 67, 20, 10, -1, 39, 139, 142,
- 143, 147, -1, 66, 159, -1, 66, 112, -1, 155,
- -1, 156, -1, 157, -1, 158, -1, 159, 82, 159,
- 83, 159, -1, 93, 159, -1, 161, -1, 69, 159,
- -1, 103, 149, 102, -1, 29, -1, 103, 102, -1,
- 167, -1, 171, -1, 169, -1, 168, -1, 170, -1,
- 154, -1, 172, 11, 149, 12, -1, 173, 11, 149,
- 12, -1, 172, 9, 149, 20, 10, -1, 173, 9,
- 149, 20, 10, -1, 26, -1, 166, -1, 166, 103,
- 102, -1, 166, 103, 149, 102, -1, 68, 141, 163,
- -1, 159, 101, 15, 18, -1, 159, 101, 16, 18,
- -1, 159, 101, 17, 18, -1, 159, 101, 19, 18,
- -1, 159, 101, 18, 18, -1, 53, -1, 53, 159,
- -1, 79, 150, -1, 59, -1, 59, 112, -1, 59,
- 159, -1, 71, -1, 71, 159, -1, 32, -1, 32,
- 159, -1, 56, -1, 56, 103, 102, -1, 30, -1,
- 30, 103, 102, -1, 31, -1, 57, 103, 102, -1,
- 57, 103, 149, 102, -1, -1, 27, 160, 103, 150,
- 102, -1, 23, -1, 151, -1, 55, -1, 34, -1,
- 70, 162, 144, -1, 70, 162, -1, 103, 149, 102,
- -1, 103, 102, -1, 167, -1, 169, -1, 168, -1,
- -1, 150, -1, -1, 149, -1, 167, -1, 19, 175,
- -1, 15, 175, -1, 16, 175, -1, 17, 175, -1,
- 65, 175, -1, 159, 101, 65, 18, -1, 18, 175,
- -1, 168, -1, 159, 101, 16, -1, 169, -1, 159,
- 101, 17, -1, 171, -1, 159, 101, 18, -1, 23,
- -1, 167, -1, 112, -1, 28, -1
+ 127, -1, 121, -1, 120, -1, 36, 121, -1, 36,
+ 120, -1, 35, -1, 37, 142, 139, 113, -1, -1,
+ 38, 143, 140, 122, 144, 145, 150, -1, 40, 23,
+ 23, 20, -1, -1, 41, 140, 123, 23, 23, 165,
+ 20, -1, 44, 103, 114, 136, 102, 115, 130, -1,
+ 45, 103, 114, 138, 102, 115, 130, -1, 50, 103,
+ 114, 136, 102, 115, -1, 51, 103, 114, 136, 102,
+ 115, -1, 52, 112, -1, 42, 103, 114, 134, 102,
+ 132, 115, 131, -1, 43, 103, 114, 135, 102, 132,
+ 115, 131, -1, -1, -1, 49, 103, 114, 137, 20,
+ 124, 134, 20, 125, 132, 137, 102, 115, -1, 49,
+ 70, 114, 167, 103, 136, 102, 115, 131, -1, 49,
+ 169, 103, 114, 136, 102, 115, 131, -1, 49, 103,
+ 114, 136, 102, 115, 131, -1, 112, 131, -1, -1,
+ 40, 23, 23, 9, 114, 126, 117, 10, -1, 129,
+ 20, -1, 20, -1, 26, 128, -1, -1, 73, 117,
+ 74, -1, 1, -1, 151, -1, 151, 44, 151, -1,
+ 151, 45, 151, -1, 151, 42, 151, -1, 151, 43,
+ 135, -1, 151, 49, 151, -1, 151, 51, 151, -1,
+ -1, 46, 115, -1, 47, 103, 136, 102, 115, 130,
+ -1, -1, 48, 112, -1, -1, -1, 129, -1, -1,
+ 151, -1, 151, -1, 151, -1, 133, -1, 135, -1,
+ 23, -1, -1, -1, -1, -1, 23, -1, 28, -1,
+ -1, 26, -1, -1, 72, 26, -1, 72, -1, 72,
+ 26, -1, 72, -1, -1, -1, 103, 148, 102, -1,
+ 114, 147, 9, 117, 10, -1, 149, -1, 20, -1,
+ 151, 78, 151, -1, 151, 77, 151, -1, 151, 76,
+ 151, -1, 152, -1, 152, 80, -1, 152, 80, 161,
+ -1, 161, -1, 60, 177, 152, -1, 58, 103, 177,
+ 151, 102, -1, 161, 101, 155, 103, 166, 102, -1,
+ 161, 101, 155, -1, 24, 177, 165, -1, 25, 177,
+ 103, 166, 102, -1, 60, 165, -1, 58, 103, 166,
+ 102, -1, -1, 33, 141, 112, 154, 165, -1, 24,
+ -1, 169, -1, 176, 9, 151, 20, 10, -1, 169,
+ 11, 151, 12, -1, 161, 101, 11, 151, 12, -1,
+ 156, 11, 151, 12, -1, 169, 9, 151, 20, 10,
+ -1, 161, 101, 9, 151, 20, 10, -1, 156, 9,
+ 151, 20, 10, -1, 161, 101, 103, 102, -1, 161,
+ 101, 103, 151, 102, -1, 156, 103, 151, 102, -1,
+ 156, 103, 102, -1, 103, 151, 102, 11, 151, 12,
+ -1, 29, 11, 151, 12, -1, 103, 102, 11, 151,
+ 12, -1, 161, 81, 161, -1, 161, 95, 161, -1,
+ 161, 63, 161, -1, 161, 64, 161, -1, 161, 89,
+ 161, -1, 161, 61, 161, -1, 161, 62, 161, -1,
+ 161, 88, 161, -1, 161, 87, 161, -1, 161, 54,
+ 161, -1, 161, 86, 161, -1, 161, 85, 161, -1,
+ 161, 84, 161, -1, 161, 90, 161, -1, 13, 161,
+ -1, 14, 161, -1, 91, 161, -1, 92, 161, -1,
+ 161, 98, -1, 161, 97, -1, 161, 96, -1, 100,
+ 161, -1, 99, 161, -1, 11, 151, 12, -1, 11,
+ 12, -1, 67, 151, 20, 10, -1, 67, 20, 10,
+ -1, 39, 141, 144, 145, 149, -1, 66, 161, -1,
+ 66, 112, -1, 157, -1, 158, -1, 159, -1, 160,
+ -1, 161, 82, 161, 83, 161, -1, 93, 161, -1,
+ 163, -1, 69, 161, -1, 103, 151, 102, -1, 29,
+ -1, 103, 102, -1, 169, -1, 173, -1, 171, -1,
+ 170, -1, 172, -1, 156, -1, 174, 11, 151, 12,
+ -1, 175, 11, 151, 12, -1, 174, 9, 151, 20,
+ 10, -1, 175, 9, 151, 20, 10, -1, 26, -1,
+ 168, -1, 168, 103, 102, -1, 168, 103, 151, 102,
+ -1, 68, 143, 165, -1, 161, 101, 15, 18, -1,
+ 161, 101, 16, 18, -1, 161, 101, 17, 18, -1,
+ 161, 101, 19, 18, -1, 161, 101, 18, 18, -1,
+ 53, -1, 53, 161, -1, 79, 152, -1, 59, -1,
+ 59, 112, -1, 59, 161, -1, 71, -1, 71, 161,
+ -1, 32, -1, 32, 161, -1, 56, -1, 56, 103,
+ 102, -1, 30, -1, 30, 103, 102, -1, 31, -1,
+ 57, 103, 102, -1, 57, 103, 151, 102, -1, -1,
+ 27, 162, 103, 152, 102, -1, 23, -1, 153, -1,
+ 55, -1, 34, -1, 70, 164, 146, -1, 70, 164,
+ -1, 103, 151, 102, -1, 103, 102, -1, 169, -1,
+ 171, -1, 170, -1, -1, 152, -1, -1, 151, -1,
+ 169, -1, 19, 177, -1, 15, 177, -1, 16, 177,
+ -1, 17, 177, -1, 65, 177, -1, 161, 101, 65,
+ 18, -1, 18, 177, -1, 170, -1, 161, 101, 16,
+ -1, 171, -1, 161, 101, 17, -1, 173, -1, 161,
+ 101, 18, -1, 23, -1, 169, -1, 112, -1, 28,
+ -1
};
/* YYRLINE[YYN] -- source line where rule number YYN was defined. */
156, 155, 168, 167, 179, 187, 195, 198, 206, 211,
212, 222, 223, 232, 236, 240, 244, 251, 253, 264,
263, 295, 303, 302, 310, 316, 322, 333, 335, 337,
- 344, 351, 366, 371, 377, 383, 390, 389, 404, 409,
- 418, 436, 437, 442, 444, 446, 448, 450, 452, 454,
- 457, 463, 464, 469, 480, 481, 487, 493, 494, 499,
- 502, 506, 511, 515, 519, 523, 524, 528, 534, 539,
- 544, 545, 550, 551, 556, 557, 559, 564, 566, 571,
- 573, 572, 591, 601, 602, 608, 610, 612, 614, 618,
- 620, 625, 629, 633, 637, 643, 648, 654, 660, 662,
- 665, 664, 675, 676, 680, 686, 689, 694, 699, 703,
- 709, 715, 718, 723, 727, 730, 732, 734, 739, 741,
- 743, 748, 750, 752, 754, 756, 758, 760, 762, 764,
- 766, 768, 773, 775, 778, 780, 782, 785, 788, 799,
- 802, 809, 811, 813, 815, 817, 824, 826, 830, 831,
- 832, 833, 834, 836, 838, 840, 842, 844, 846, 848,
- 850, 852, 854, 856, 858, 860, 870, 880, 891, 902,
- 904, 906, 909, 914, 918, 920, 922, 924, 927, 929,
- 932, 934, 936, 938, 940, 942, 944, 946, 948, 951,
- 953, 955, 957, 959, 961, 965, 968, 967, 980, 981,
- 982, 987, 991, 993, 998, 1000, 1003, 1005, 1007, 1012,
- 1014, 1019, 1020, 1026, 1030, 1034, 1038, 1044, 1050, 1052,
- 1056, 1060, 1061, 1065, 1066, 1070, 1071, 1076, 1078, 1080,
- 1083
+ 344, 352, 354, 351, 370, 375, 381, 387, 394, 393,
+ 408, 412, 420, 438, 439, 444, 446, 448, 450, 452,
+ 454, 456, 459, 465, 466, 471, 482, 483, 489, 495,
+ 496, 501, 504, 508, 513, 517, 521, 525, 526, 530,
+ 536, 541, 546, 547, 552, 553, 558, 559, 561, 566,
+ 568, 573, 575, 574, 593, 603, 604, 608, 610, 612,
+ 614, 618, 620, 625, 629, 633, 637, 643, 648, 654,
+ 660, 662, 665, 664, 675, 676, 680, 684, 687, 692,
+ 697, 700, 704, 708, 711, 716, 720, 723, 725, 727,
+ 732, 734, 736, 741, 743, 745, 747, 749, 751, 753,
+ 755, 757, 759, 761, 766, 768, 771, 773, 775, 778,
+ 781, 792, 795, 802, 804, 806, 808, 810, 817, 819,
+ 823, 824, 825, 826, 827, 829, 831, 833, 835, 837,
+ 839, 841, 843, 845, 847, 849, 851, 853, 863, 873,
+ 883, 893, 895, 897, 900, 905, 909, 911, 913, 915,
+ 918, 920, 923, 925, 927, 929, 931, 933, 935, 937,
+ 939, 942, 944, 946, 948, 950, 952, 956, 959, 958,
+ 971, 972, 973, 978, 982, 984, 989, 991, 994, 996,
+ 998, 1003, 1005, 1010, 1011, 1017, 1021, 1025, 1029, 1035,
+ 1041, 1043, 1047, 1051, 1052, 1056, 1057, 1061, 1062, 1067,
+ 1069, 1071, 1074
};
#endif
-#if YYDEBUG || YYERROR_VERBOSE || 0
+#if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE
/* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM.
First, the terminals, then, starting at YYNTOKENS, nonterminals. */
static const char *const yytname[] =
"ANDOP", "NOTOP", "','", "ASSIGNOP", "'?'", "':'", "DORDOR", "OROR",
"ANDAND", "BITOROP", "BITANDOP", "SHIFTOP", "MATCHOP", "'!'", "'~'",
"REFGEN", "UMINUS", "POWOP", "POSTJOIN", "POSTDEC", "POSTINC", "PREDEC",
- "PREINC", "ARROW", "')'", "'('", "$accept", "grammar", "$@1", "$@2",
- "$@3", "$@4", "$@5", "$@6", "block", "formblock", "remember", "mblock",
+ "PREINC", "ARROW", "')'", "'('", "$accept", "grammar", "@1", "@2", "@3",
+ "@4", "@5", "@6", "block", "formblock", "remember", "mblock",
"mremember", "stmtseq", "formstmtseq", "fullstmt", "labfullstmt",
- "barestmt", "$@7", "$@8", "$@9", "formline", "formarg", "sideff", "else",
- "cont", "mintro", "nexpr", "texpr", "iexpr", "mexpr", "mnexpr", "miexpr",
- "formname", "startsub", "startanonsub", "startformsub", "subname",
- "proto", "subattrlist", "myattrlist", "subsignature", "@10",
- "realsubbody", "optsubbody", "expr", "listexpr", "listop", "@11",
- "method", "subscripted", "termbinop", "termunop", "anonymous", "termdo",
- "term", "@12", "myattrterm", "myterm", "optlistexpr", "optexpr",
- "my_scalar", "amper", "scalar", "ary", "hsh", "arylen", "star",
- "sliceme", "kvslice", "gelem", "indirob", YY_NULL
+ "barestmt", "@7", "@8", "@9", "@10", "@11", "formline", "formarg",
+ "sideff", "else", "cont", "mintro", "nexpr", "texpr", "iexpr", "mexpr",
+ "mnexpr", "miexpr", "formname", "startsub", "startanonsub",
+ "startformsub", "subname", "proto", "subattrlist", "myattrlist",
+ "subsignature", "@12", "realsubbody", "optsubbody", "expr", "listexpr",
+ "listop", "@13", "method", "subscripted", "termbinop", "termunop",
+ "anonymous", "termdo", "term", "@14", "myattrterm", "myterm",
+ "optlistexpr", "optexpr", "my_scalar", "amper", "scalar", "ary", "hsh",
+ "arylen", "star", "sliceme", "kvslice", "gelem", "indirob", 0
};
#endif
110, 105, 111, 105, 112, 113, 114, 115, 116, 117,
117, 118, 118, 119, 119, 120, 120, 121, 121, 122,
121, 121, 123, 121, 121, 121, 121, 121, 121, 121,
- 121, 121, 121, 121, 121, 121, 124, 121, 121, 121,
- 125, 126, 126, 127, 127, 127, 127, 127, 127, 127,
- 127, 128, 128, 128, 129, 129, 130, 131, 131, 132,
- 132, 133, 134, 135, 136, 137, 137, 138, 139, 140,
- 141, 141, 142, 142, 143, 143, 143, 144, 144, 145,
- 146, 145, 147, 148, 148, 149, 149, 149, 149, 150,
- 150, 150, 151, 151, 151, 151, 151, 151, 151, 151,
- 152, 151, 153, 153, 154, 154, 154, 154, 154, 154,
- 154, 154, 154, 154, 154, 154, 154, 154, 155, 155,
- 155, 155, 155, 155, 155, 155, 155, 155, 155, 155,
- 155, 155, 156, 156, 156, 156, 156, 156, 156, 156,
- 156, 157, 157, 157, 157, 157, 158, 158, 159, 159,
- 159, 159, 159, 159, 159, 159, 159, 159, 159, 159,
- 159, 159, 159, 159, 159, 159, 159, 159, 159, 159,
- 159, 159, 159, 159, 159, 159, 159, 159, 159, 159,
- 159, 159, 159, 159, 159, 159, 159, 159, 159, 159,
- 159, 159, 159, 159, 159, 159, 160, 159, 159, 159,
- 159, 159, 161, 161, 162, 162, 162, 162, 162, 163,
- 163, 164, 164, 165, 166, 167, 168, 169, 170, 170,
- 171, 172, 172, 173, 173, 174, 174, 175, 175, 175,
- 175
+ 121, 124, 125, 121, 121, 121, 121, 121, 126, 121,
+ 121, 121, 127, 128, 128, 129, 129, 129, 129, 129,
+ 129, 129, 129, 130, 130, 130, 131, 131, 132, 133,
+ 133, 134, 134, 135, 136, 137, 138, 139, 139, 140,
+ 141, 142, 143, 143, 144, 144, 145, 145, 145, 146,
+ 146, 147, 148, 147, 149, 150, 150, 151, 151, 151,
+ 151, 152, 152, 152, 153, 153, 153, 153, 153, 153,
+ 153, 153, 154, 153, 155, 155, 156, 156, 156, 156,
+ 156, 156, 156, 156, 156, 156, 156, 156, 156, 156,
+ 157, 157, 157, 157, 157, 157, 157, 157, 157, 157,
+ 157, 157, 157, 157, 158, 158, 158, 158, 158, 158,
+ 158, 158, 158, 159, 159, 159, 159, 159, 160, 160,
+ 161, 161, 161, 161, 161, 161, 161, 161, 161, 161,
+ 161, 161, 161, 161, 161, 161, 161, 161, 161, 161,
+ 161, 161, 161, 161, 161, 161, 161, 161, 161, 161,
+ 161, 161, 161, 161, 161, 161, 161, 161, 161, 161,
+ 161, 161, 161, 161, 161, 161, 161, 161, 162, 161,
+ 161, 161, 161, 161, 163, 163, 164, 164, 164, 164,
+ 164, 165, 165, 166, 166, 167, 168, 169, 170, 171,
+ 172, 172, 173, 174, 174, 175, 175, 176, 176, 177,
+ 177, 177, 177
};
/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */
0, 3, 0, 3, 4, 7, 0, 4, 0, 0,
2, 0, 2, 1, 1, 2, 2, 1, 4, 0,
7, 4, 0, 7, 7, 7, 6, 6, 2, 8,
- 8, 11, 9, 8, 7, 2, 0, 8, 2, 1,
- 2, 0, 3, 1, 1, 3, 3, 3, 3, 3,
- 3, 0, 2, 6, 0, 2, 0, 0, 1, 0,
- 1, 1, 1, 1, 1, 1, 0, 0, 0, 0,
- 1, 1, 0, 1, 0, 2, 1, 2, 1, 0,
- 0, 3, 5, 1, 1, 3, 3, 3, 1, 2,
- 3, 1, 3, 5, 6, 3, 3, 5, 2, 4,
- 0, 5, 1, 1, 5, 4, 5, 4, 5, 6,
- 5, 4, 5, 4, 3, 6, 4, 5, 3, 3,
+ 8, 0, 0, 13, 9, 8, 7, 2, 0, 8,
+ 2, 1, 2, 0, 3, 1, 1, 3, 3, 3,
+ 3, 3, 3, 0, 2, 6, 0, 2, 0, 0,
+ 1, 0, 1, 1, 1, 1, 1, 1, 0, 0,
+ 0, 0, 1, 1, 0, 1, 0, 2, 1, 2,
+ 1, 0, 0, 3, 5, 1, 1, 3, 3, 3,
+ 1, 2, 3, 1, 3, 5, 6, 3, 3, 5,
+ 2, 4, 0, 5, 1, 1, 5, 4, 5, 4,
+ 5, 6, 5, 4, 5, 4, 3, 6, 4, 5,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
- 3, 3, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 3, 2, 4, 3, 5, 2, 2, 1, 1,
- 1, 1, 5, 2, 1, 2, 3, 1, 2, 1,
- 1, 1, 1, 1, 1, 4, 4, 5, 5, 1,
- 1, 3, 4, 3, 4, 4, 4, 4, 4, 1,
- 2, 2, 1, 2, 2, 1, 2, 1, 2, 1,
- 3, 1, 3, 1, 3, 4, 0, 5, 1, 1,
- 1, 1, 3, 2, 3, 2, 1, 1, 1, 0,
- 1, 0, 1, 1, 2, 2, 2, 2, 2, 4,
- 2, 1, 3, 1, 3, 1, 3, 1, 1, 1,
- 1
+ 3, 3, 3, 3, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 3, 2, 4, 3, 5, 2, 2,
+ 1, 1, 1, 1, 5, 2, 1, 2, 3, 1,
+ 2, 1, 1, 1, 1, 1, 1, 4, 4, 5,
+ 5, 1, 1, 3, 4, 3, 4, 4, 4, 4,
+ 4, 1, 2, 2, 1, 2, 2, 1, 2, 1,
+ 2, 1, 3, 1, 3, 1, 3, 4, 0, 5,
+ 1, 1, 1, 1, 3, 2, 3, 2, 1, 1,
+ 1, 0, 1, 0, 1, 1, 2, 2, 2, 2,
+ 2, 4, 2, 1, 3, 1, 3, 1, 3, 1,
+ 1, 1, 1
};
-/* YYDEFACT[STATE-NAME] -- Default reduction number in state STATE-NUM.
- Performed when YYTABLE doesn't specify something else to do. Zero
+/* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state
+ STATE-NUM when YYTABLE doesn't specify something else to do. Zero
means the default is an error. */
static const yytype_uint8 yydefact[] =
{
- 0, 2, 4, 6, 8, 10, 12, 0, 16, 221,
+ 0, 2, 4, 6, 8, 10, 12, 0, 16, 223,
0, 0, 0, 19, 1, 19, 0, 0, 0, 0,
- 0, 0, 0, 0, 208, 0, 0, 179, 206, 167,
- 201, 203, 197, 78, 211, 78, 189, 210, 199, 0,
- 0, 192, 219, 0, 0, 0, 0, 0, 0, 195,
- 0, 0, 0, 0, 0, 0, 0, 222, 98, 209,
- 174, 158, 159, 160, 161, 101, 164, 5, 180, 169,
- 172, 171, 173, 170, 0, 0, 0, 16, 7, 53,
- 49, 27, 79, 0, 0, 77, 0, 0, 0, 0,
- 0, 0, 0, 0, 64, 9, 0, 54, 0, 11,
- 24, 23, 0, 0, 152, 0, 142, 143, 237, 240,
- 239, 238, 225, 226, 227, 230, 224, 219, 0, 0,
- 0, 0, 198, 0, 82, 190, 0, 0, 221, 193,
- 194, 237, 220, 108, 238, 0, 228, 157, 156, 0,
- 0, 80, 81, 219, 165, 0, 213, 216, 218, 217,
- 196, 191, 144, 145, 163, 150, 149, 168, 0, 0,
- 0, 0, 99, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 210, 0, 0, 181, 208, 169,
+ 203, 205, 199, 80, 213, 80, 191, 212, 201, 0,
+ 0, 194, 221, 0, 0, 0, 0, 0, 0, 197,
+ 0, 0, 0, 0, 0, 0, 0, 224, 100, 211,
+ 176, 160, 161, 162, 163, 103, 166, 5, 182, 171,
+ 174, 173, 175, 172, 0, 0, 0, 16, 7, 55,
+ 51, 27, 81, 0, 0, 79, 0, 0, 0, 0,
+ 0, 0, 0, 0, 66, 9, 0, 56, 0, 11,
+ 24, 23, 0, 0, 154, 0, 144, 145, 239, 242,
+ 241, 240, 227, 228, 229, 232, 226, 221, 0, 0,
+ 0, 0, 200, 0, 84, 192, 0, 0, 223, 195,
+ 196, 239, 222, 110, 240, 0, 230, 159, 158, 0,
+ 0, 82, 83, 221, 167, 0, 215, 218, 220, 219,
+ 198, 193, 146, 147, 165, 152, 151, 170, 0, 0,
+ 0, 0, 101, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 148, 147, 146, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 19, 76, 77, 0, 32, 16, 16,
- 16, 16, 16, 16, 0, 16, 16, 38, 0, 45,
- 48, 0, 0, 0, 0, 0, 0, 26, 25, 20,
- 151, 106, 221, 0, 0, 202, 110, 83, 84, 200,
- 204, 0, 0, 0, 102, 154, 0, 183, 215, 0,
- 88, 212, 0, 166, 97, 96, 95, 100, 0, 0,
- 124, 0, 137, 133, 134, 130, 131, 128, 0, 140,
- 139, 138, 136, 135, 132, 141, 129, 0, 0, 0,
- 232, 234, 236, 0, 112, 0, 0, 105, 113, 181,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 75,
- 0, 29, 0, 0, 69, 0, 0, 0, 0, 0,
- 16, 0, 0, 65, 57, 58, 71, 55, 56, 59,
- 60, 0, 0, 126, 219, 86, 16, 205, 109, 0,
- 153, 214, 87, 0, 0, 0, 117, 123, 0, 0,
- 0, 184, 185, 186, 188, 187, 229, 121, 0, 221,
- 182, 0, 115, 0, 175, 0, 176, 0, 14, 16,
- 28, 82, 16, 31, 0, 0, 70, 0, 0, 72,
- 74, 0, 0, 223, 68, 73, 0, 0, 54, 0,
- 0, 0, 107, 207, 111, 85, 89, 155, 103, 127,
- 0, 120, 162, 0, 116, 122, 0, 118, 177, 178,
- 114, 0, 84, 46, 219, 66, 66, 0, 0, 0,
- 0, 69, 0, 0, 0, 90, 0, 125, 119, 104,
- 0, 16, 19, 0, 0, 0, 18, 61, 61, 0,
- 64, 0, 0, 36, 37, 0, 19, 21, 94, 93,
- 30, 0, 33, 64, 64, 19, 0, 0, 34, 35,
- 0, 44, 66, 64, 91, 0, 0, 47, 39, 40,
- 0, 62, 0, 64, 0, 43, 92, 0, 51, 22,
- 17, 0, 42, 0, 15, 19, 50, 0, 0, 0,
- 61, 41, 52, 63
+ 0, 150, 149, 148, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 19, 78, 79, 0, 32, 16, 16,
+ 16, 16, 16, 16, 0, 16, 16, 38, 0, 47,
+ 50, 0, 0, 0, 0, 0, 0, 26, 25, 20,
+ 153, 108, 223, 0, 0, 204, 112, 85, 86, 202,
+ 206, 0, 0, 0, 104, 156, 0, 185, 217, 0,
+ 90, 214, 0, 168, 99, 98, 97, 102, 0, 0,
+ 126, 0, 139, 135, 136, 132, 133, 130, 0, 142,
+ 141, 140, 138, 137, 134, 143, 131, 0, 0, 0,
+ 234, 236, 238, 0, 114, 0, 0, 107, 115, 183,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 77,
+ 0, 29, 0, 0, 71, 0, 0, 0, 0, 0,
+ 16, 0, 0, 67, 59, 60, 73, 57, 58, 61,
+ 62, 0, 0, 128, 221, 88, 16, 207, 111, 0,
+ 155, 216, 89, 0, 0, 0, 119, 125, 0, 0,
+ 0, 186, 187, 188, 190, 189, 231, 123, 0, 223,
+ 184, 0, 117, 0, 177, 0, 178, 0, 14, 16,
+ 28, 84, 16, 31, 0, 0, 72, 0, 0, 74,
+ 76, 0, 0, 225, 70, 75, 0, 0, 56, 0,
+ 0, 0, 109, 209, 113, 87, 91, 157, 105, 129,
+ 0, 122, 164, 0, 118, 124, 0, 120, 179, 180,
+ 116, 0, 86, 48, 221, 68, 68, 0, 0, 0,
+ 0, 41, 0, 0, 0, 92, 0, 127, 121, 106,
+ 0, 16, 19, 0, 0, 0, 18, 63, 63, 0,
+ 66, 71, 0, 36, 37, 0, 19, 21, 96, 95,
+ 30, 0, 33, 66, 66, 19, 0, 0, 34, 35,
+ 0, 46, 0, 66, 93, 0, 0, 49, 39, 40,
+ 0, 64, 0, 66, 42, 45, 94, 0, 53, 22,
+ 17, 0, 44, 68, 15, 19, 52, 0, 0, 0,
+ 63, 0, 54, 65, 0, 43
};
/* YYDEFGOTO[NTERM-NUM]. */
{
-1, 7, 8, 9, 10, 11, 12, 13, 110, 350,
376, 417, 435, 102, 446, 219, 100, 101, 351, 293,
- 412, 459, 466, 96, 438, 209, 414, 365, 355, 305,
- 358, 367, 361, 290, 197, 123, 194, 143, 228, 316,
- 241, 406, 425, 377, 430, 97, 58, 59, 314, 277,
- 60, 61, 62, 63, 64, 65, 119, 66, 146, 133,
- 67, 362, 68, 69, 70, 71, 72, 73, 74, 75,
- 76, 112
+ 421, 463, 412, 459, 466, 96, 438, 209, 414, 365,
+ 355, 305, 358, 367, 361, 290, 197, 123, 194, 143,
+ 228, 316, 241, 406, 425, 377, 430, 97, 58, 59,
+ 314, 277, 60, 61, 62, 63, 64, 65, 119, 66,
+ 146, 133, 67, 362, 68, 69, 70, 71, 72, 73,
+ 74, 75, 76, 112
};
/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing
STATE-NUM. */
-#define YYPACT_NINF -408
+#define YYPACT_NINF -409
static const yytype_int16 yypact[] =
{
- 714, -408, -408, -408, -408, -408, -408, 5, -408, 2549,
- 20, 1201, 1108, -408, -408, -408, 1809, 2549, 2549, 608,
- 608, 608, 608, 608, -408, 608, 608, -408, -408, 48,
- -67, -408, 2549, -408, -408, -408, 2549, -408, -54, -41,
- -26, 1716, 1623, 608, 1716, 1900, 50, 2549, 40, 2549,
- 2549, 2549, 2549, 2549, 2549, 2549, 1991, 226, 21, -408,
- 11, -408, -408, -408, -408, 2617, -408, -408, -8, 107,
- 136, 155, -408, 98, 220, 251, 110, -408, -408, -408,
- -408, -408, -408, 50, 77, -408, 19, 26, 37, 41,
- 1, 45, 51, 20, 93, -408, 135, 367, 1108, -408,
- -408, -408, 447, 542, -408, -2, 614, 614, -408, -408,
- -408, -408, -408, -408, -408, -408, -408, 2549, 56, 100,
- 2549, 92, 1701, 20, 188, 2617, 124, 2084, 1623, -408,
- 1701, 1529, 21, -408, 1450, 2549, -408, -408, 1701, 225,
- 3, -408, -408, 2549, 1701, 2177, 168, -408, -408, -408,
- 1701, 21, 614, 614, 614, 354, 354, 232, -50, 2549,
+ 706, -409, -409, -409, -409, -409, -409, 19, -409, 2549,
+ 2, 1201, 1108, -409, -409, -409, 1809, 2549, 2549, 50,
+ 50, 50, 50, 50, -409, 50, 50, -409, -409, 52,
+ -74, -409, 2549, -409, -409, -409, 2549, -409, -67, -54,
+ -9, 1716, 1623, 50, 1716, 1900, 46, 2549, 40, 2549,
+ 2549, 2549, 2549, 2549, 2549, 2549, 1991, 274, 20, -409,
+ 11, -409, -409, -409, -409, 2617, -409, -409, -8, 98,
+ 107, 220, -409, 61, 229, 263, 92, -409, -409, -409,
+ -409, -409, -409, 46, 106, -409, 37, 41, 47, 63,
+ 1, 100, 111, 2, 73, -409, 135, 368, 1108, -409,
+ -409, -409, 447, 542, -409, 9, 432, 432, -409, -409,
+ -409, -409, -409, -409, -409, -409, -409, 2549, 130, 134,
+ 2549, 124, 280, 2, 137, 2617, 141, 2084, 1623, -409,
+ 280, 1529, 20, -409, 1450, 2549, -409, -409, 280, 184,
+ 3, -409, -409, 2549, 280, 2177, 170, -409, -409, -409,
+ 280, 20, 432, 432, 432, 296, 296, 251, -50, 2549,
2549, 2549, 2549, 2549, 2549, 2270, 2549, 2549, 2549, 2549,
2549, 2549, 2549, 2549, 2549, 2549, 2549, 2549, 2549, 2549,
- 2549, -408, -408, -408, 252, 2363, 2549, 2549, 2549, 2549,
- 2549, 2549, 2549, -408, 221, -408, 259, -408, -408, -408,
- -408, -408, -408, -408, 171, -408, -408, -408, 20, -408,
- -408, 2549, 2549, 2549, 2549, 2549, 2549, -408, -408, -408,
- -408, -408, 2549, 2549, 9, -408, -408, -408, 211, -408,
- -408, 140, 184, 2549, 21, -408, 295, -408, -408, 212,
- 284, -408, 2549, 302, 240, 240, -408, 2617, 74, 13,
- -408, 291, 341, 1608, 245, 529, 432, 2617, 2572, 289,
- 289, 1279, 1420, 1499, 1332, 614, 614, 2549, 2549, 257,
- 309, 313, 321, 326, -408, 327, 2456, 217, -408, -408,
- 304, 101, 60, 119, 91, 129, 94, 156, 637, -408,
- 328, -408, 15, 324, 2549, 2549, 2549, 2549, 339, 1294,
- -408, 2549, 2549, -408, 226, -408, 226, 226, 226, 226,
- 226, 254, -48, -408, 2549, 334, -408, -408, -408, 433,
- -408, -408, -408, 97, 2549, 352, -408, -408, 2549, 160,
- 115, -408, -408, -408, -408, -408, -408, -408, 443, 2549,
- -408, 353, -408, 360, -408, 362, -408, 363, -408, -408,
- -408, 188, -408, -408, 365, 287, 226, 290, 292, 226,
- -408, 297, 288, -408, -408, -408, 299, 377, 281, 2549,
- 306, 311, -408, -408, -408, -408, 312, -408, -408, -408,
- 123, -408, 2662, 407, -408, -408, 317, -408, -408, -408,
- -408, 400, 211, -408, 2549, -408, -408, 413, 413, 2549,
- 413, 2549, 322, 413, 413, -408, 423, -408, -408, -408,
- 359, 414, -408, 421, 413, 413, -408, 23, 23, 344,
- 93, 434, 413, -408, -408, 355, -408, -408, -408, -408,
- -408, 732, -408, 93, 93, -408, 413, 366, -408, -408,
- 413, -408, -408, 93, -408, 827, 38, -408, -408, -408,
- 922, -408, 2549, 93, 1387, -408, -408, 446, 402, -408,
- -408, 391, -408, 392, -408, -408, -408, 413, 413, 1015,
- 23, -408, -408, -408
+ 2549, -409, -409, -409, 252, 2363, 2549, 2549, 2549, 2549,
+ 2549, 2549, 2549, -409, 243, -409, 256, -409, -409, -409,
+ -409, -409, -409, -409, 172, -409, -409, -409, 2, -409,
+ -409, 2549, 2549, 2549, 2549, 2549, 2549, -409, -409, -409,
+ -409, -409, 2549, 2549, 13, -409, -409, -409, 210, -409,
+ -409, 71, 181, 2549, 20, -409, 275, -409, -409, 158,
+ 260, -409, 2549, 293, 228, 228, -409, 2617, 99, 60,
+ -409, 261, 341, 1794, 1608, 527, 217, 2617, 2572, 1280,
+ 1280, 1420, 1499, 1701, 290, 432, 432, 2549, 2549, 136,
+ 292, 310, 311, 313, -409, 322, 2456, 208, -409, -409,
+ 271, 102, 91, 119, 94, 212, 115, 224, 637, -409,
+ 321, -409, 15, 323, 2549, 2549, 2549, 2549, 345, 1294,
+ -409, 2549, 2549, -409, 274, -409, 274, 274, 274, 274,
+ 274, 254, -48, -409, 2549, 336, -409, -409, -409, 417,
+ -409, -409, -409, 123, 2549, 354, -409, -409, 2549, 257,
+ 129, -409, -409, -409, -409, -409, -409, -409, 433, 2549,
+ -409, 355, -409, 357, -409, 358, -409, 372, -409, -409,
+ -409, 137, -409, -409, 361, 287, 274, 288, 297, 274,
+ -409, 299, 295, -409, -409, -409, 304, 388, 281, 2549,
+ 307, 314, -409, -409, -409, -409, 312, -409, -409, -409,
+ 140, -409, 2662, 410, -409, -409, 320, -409, -409, -409,
+ -409, 404, 210, -409, 2549, -409, -409, 423, 423, 2549,
+ 423, -409, 331, 423, 423, -409, 425, -409, -409, -409,
+ 367, 430, -409, 431, 423, 423, -409, 30, 30, 350,
+ 73, 2549, 423, -409, -409, 352, -409, -409, -409, -409,
+ -409, 732, -409, 73, 73, -409, 423, 340, -409, -409,
+ 423, -409, 435, 73, -409, 827, 38, -409, -409, -409,
+ 922, -409, 2549, 73, -409, -409, -409, 446, 384, -409,
+ -409, 373, -409, -409, -409, -409, -409, 423, 1387, 1015,
+ 30, 399, -409, -409, 423, -409
};
/* YYPGOTO[NTERM-NUM]. */
static const yytype_int16 yypgoto[] =
{
- -408, -408, -408, -408, -408, -408, -408, -408, -10, -408,
- 22, -103, -408, -12, -408, 489, 410, 7, -408, -408,
- -408, -408, -408, -291, -407, -105, -377, -408, 122, -18,
- -287, 70, -408, -408, 330, 496, -408, 449, 183, 144,
- -408, -408, -408, 126, -408, -3, -33, -408, -408, -408,
- -408, -408, -408, -408, -408, 79, -408, -408, -408, -110,
- -124, -408, -408, 18, 493, 500, -408, -408, -408, -408,
- -408, 25
+ -409, -409, -409, -409, -409, -409, -409, -409, -10, -409,
+ 22, -95, -409, -12, -409, 457, 422, 7, -409, -409,
+ -409, -409, -409, -409, -409, -294, -408, 88, -388, -409,
+ 103, 0, -287, 55, -409, -409, 330, 497, -409, 451,
+ 185, 145, -409, -409, -409, 133, -409, -3, -33, -409,
+ -409, -409, -409, -409, -409, -409, -409, 79, -409, -409,
+ -409, -110, -124, -409, -409, 18, 500, 501, -409, -409,
+ -409, -409, -409, 25
};
/* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If
positive, shift that token. If negative, reduce the rule which
- number is the opposite. If YYTABLE_NINF, syntax error. */
-#define YYTABLE_NINF -236
+ number is the opposite. If zero, do what YYDEFACT says.
+ If YYTABLE_NINF, syntax error. */
+#define YYTABLE_NINF -238
static const yytype_int16 yytable[] =
{
- 78, 94, 94, 103, 232, 14, 57, 221, 364, 132,
- 220, 439, 366, 105, 370, 371, 19, 151, 95, 415,
- 163, 313, 164, 236, 352, 326, 159, 160, 161, 77,
- 15, 129, 162, 237, 137, 353, 121, 111, 111, 111,
- 111, 111, 140, 111, 111, 113, 114, 115, 116, 126,
- 117, 118, 243, 158, 373, 19, 20, 21, 457, 120,
- 134, 111, 127, 473, 458, 454, 147, 135, 136, 436,
- 437, 202, 342, 141, 159, 160, 161, 128, 142, 159,
+ 78, 94, 94, 103, 232, 364, 57, 221, 415, 132,
+ 439, 77, 366, 105, 370, 371, 19, 151, 95, 14,
+ 163, 220, 164, 236, 352, 313, 159, 160, 161, 121,
+ 15, 129, 162, 237, 137, 353, 126, 111, 111, 111,
+ 111, 111, 140, 111, 111, 113, 114, 115, 116, 127,
+ 117, 118, 243, 158, 373, 19, 20, 21, 457, 77,
+ 134, 111, 473, 120, 458, 19, 147, 135, 136, 141,
+ -237, 202, 326, 108, 142, 468, 436, 437, 109, 159,
160, 161, 402, 207, 132, 159, 160, 161, 94, 159,
- 160, 161, 94, 94, 325, 185, 106, 107, 311, 193,
- 196, 162, 234, 344, 203, 218, 346, -235, 204, 379,
- 132, 122, 419, 226, 165, 125, 186, 224, 187, 192,
- 130, 341, 198, 138, 231, 57, 144, 384, 150, 199,
- 152, 153, 154, 155, 156, 407, 159, 160, 161, 343,
- 200, 208, 239, 145, 201, -231, 134, -231, 205, 345,
- 159, 160, 161, 233, 206, 210, 244, 245, 246, 222,
- 248, 249, 251, 364, -233, 461, -233, 159, 160, 161,
- 159, 160, 161, 159, 160, 161, 347, 159, 160, 161,
- 383, 288, 280, 281, 282, 283, 284, 285, 286, 287,
- 312, 159, 160, 161, 225, 159, 160, 161, 303, 159,
- 160, 161, 278, 223, 374, 159, 160, 161, 304, 306,
- 307, 308, 309, 310, 227, 386, 159, 160, 161, 57,
- 294, 295, 296, 297, 298, 299, 229, 301, 302, 188,
- 319, 189, 159, 160, 161, 235, 159, 160, 161, 323,
- 240, 247, 317, 242, 289, 252, 253, 254, 255, 256,
+ 160, 161, 94, 94, 128, 185, 106, 107, 311, 193,
+ 162, 192, 234, 342, 203, 218, 344, 186, 204, 187,
+ 132, 122, 419, 226, 165, 125, -233, 224, -233, 325,
+ 130, 208, 341, 138, 231, 57, 144, 346, 150, 196,
+ 152, 153, 154, 155, 156, 379, 159, 160, 161, 343,
+ 198, 384, 239, 145, 199, 77, 134, 159, 160, 161,
+ 200, 19, 407, 233, 331, 210, 244, 245, 246, 108,
+ 248, 249, 251, 227, 109, 461, 201, 159, 160, 161,
+ 159, 160, 161, 317, 364, 159, 160, 161, 159, 160,
+ 161, 288, 280, 281, 282, 283, 284, 285, 286, 287,
+ 312, 159, 160, 161, 235, 159, 160, 161, 303, 159,
+ 160, 161, 278, 205, 374, 159, 160, 161, 304, 306,
+ 307, 308, 309, 310, 206, 386, 159, 160, 161, 57,
+ 294, 295, 296, 297, 298, 299, 225, 301, 302, -235,
+ 319, -235, 345, 222, 159, 160, 161, 223, 188, 323,
+ 189, 247, 240, 229, 347, 252, 253, 254, 255, 256,
257, 258, 259, 260, 261, 262, 263, 264, 265, 266,
- 190, 267, 191, 268, 329, 330, 77, 269, 270, 271,
- 272, 273, 19, 338, 300, 331, 274, 357, 94, 360,
- 108, 132, 292, 315, 413, 109, 318, 111, 159, 160,
- 161, 356, 306, 359, 306, 418, 368, 420, 359, 359,
- 423, 424, 159, 160, 161, 320, 167, -236, 169, 170,
- 322, 433, 434, 324, 321, 441, 363, 275, 161, 443,
- 339, 380, 369, 211, 212, 213, 214, 332, 448, 449,
- 215, 333, 216, 451, 178, 179, 57, 453, 455, 334,
- 180, 181, 182, 183, 335, 336, 184, 354, 462, 349,
- 167, 168, 169, 170, 19, 276, 372, 159, 160, 161,
- 375, 132, 381, 387, 470, 471, 359, 159, 160, 161,
- 388, 391, 389, 390, 393, 175, 176, 177, 178, 179,
- 159, 160, 161, -72, 180, 181, 182, 183, 394, 395,
- 184, 399, 396, 327, 397, -236, 359, 401, 356, 398,
- 431, 400, 167, 168, 169, 170, 340, 382, 403, 211,
- 212, 213, 214, 404, 445, 405, 215, 408, 216, 409,
- 410, 94, 416, 450, 422, 173, 174, 175, 176, 177,
- 178, 179, 426, 427, 428, 94, 180, 181, 182, 183,
- 94, 432, 184, 159, 160, 161, 440, -13, 79, 359,
- -236, -236, -236, 469, 442, 184, 77, 444, 16, 94,
- 17, 18, 19, 20, 21, 22, 23, 80, 464, 452,
- 24, 25, 26, 27, 28, 465, 29, 30, 31, 32,
+ 321, 267, 242, 268, 329, 330, 289, 269, 270, 271,
+ 272, 273, 190, 338, 191, 300, 274, 383, 94, 292,
+ 169, 132, 315, 318, 413, 320, 322, 111, 159, 160,
+ 161, 356, 306, 359, 306, 357, 368, 360, 359, 359,
+ 159, 160, 161, 418, 324, 420, 161, 179, 423, 424,
+ 332, 339, 180, 181, 182, 183, 363, 275, 184, 433,
+ 434, 380, 369, 211, 212, 213, 214, 443, 333, 334,
+ 215, 335, 216, 159, 160, 161, 57, 159, 160, 161,
+ 336, 451, 349, 169, 170, 453, 354, 159, 160, 161,
+ 159, 160, 161, 169, 170, 276, 372, 159, 160, 161,
+ 19, 132, 375, 327, 381, 387, 359, 388, 389, 178,
+ 179, 391, 470, 340, 393, 180, 181, 182, 183, 475,
+ 179, 184, 390, -74, 394, 180, 181, 182, 183, 395,
+ 396, 184, -238, -238, -238, -238, 359, 184, 399, 397,
+ 431, 398, 167, 168, 169, 170, 400, 382, 401, 403,
+ 211, 212, 213, 214, 445, 405, 404, 215, 356, 216,
+ 408, 94, 409, 450, 410, 173, 174, 175, 176, 177,
+ 178, 179, 416, 422, 426, 94, 180, 181, 182, 183,
+ 94, 427, 184, 452, 159, 160, 161, -13, 79, 359,
+ 428, 432, 440, 469, 444, 454, 77, 465, 16, 94,
+ 17, 18, 19, 20, 21, 22, 23, 80, 464, 99,
+ 24, 25, 26, 27, 28, 467, 29, 30, 31, 32,
33, 34, 81, 98, 82, 83, 35, 84, 85, 86,
- 87, 88, 89, 467, 468, 169, 90, 91, 92, 93,
- 36, 99, 37, 38, 39, 40, 41, 42, 217, 159,
- 160, 161, 43, 44, 45, 46, 47, 48, 49, 159,
- 160, 161, 179, 421, 463, 291, 50, 180, 181, 182,
- 183, 124, 195, 184, 392, 378, 411, 429, 51, 52,
- 53, 148, -3, 79, 0, 385, 54, 55, 149, 0,
+ 87, 88, 89, 159, 160, 161, 90, 91, 92, 93,
+ 36, 474, 37, 38, 39, 40, 41, 42, 441, 159,
+ 160, 161, 43, 44, 45, 46, 47, 48, 49, 378,
+ 217, 448, 449, 471, 442, 291, 50, 180, 181, 182,
+ 183, 455, 124, 184, 195, 385, 392, 411, 51, 52,
+ 53, 462, -3, 79, 429, 0, 54, 55, 148, 149,
56, 77, 0, 16, 0, 17, 18, 19, 20, 21,
22, 23, 80, 0, 0, 24, 25, 26, 27, 28,
0, 29, 30, 31, 32, 33, 34, 81, 98, 82,
83, 35, 84, 85, 86, 87, 88, 89, 0, 0,
0, 90, 91, 92, 93, 36, 0, 37, 38, 39,
40, 41, 42, 0, 0, 0, 0, 43, 44, 45,
- 46, 47, 48, 49, 0, 0, 0, 77, 0, 179,
- 0, 50, 0, 19, 180, 181, 182, 183, 0, 0,
- 184, 108, 0, 51, 52, 53, 109, 0, 79, 0,
+ 46, 47, 48, 49, 0, 0, 0, 179, 0, 0,
+ 0, 50, 180, 181, 182, 183, 0, 0, 184, 0,
+ 0, 0, 0, 51, 52, 53, 0, 0, 79, 0,
0, 54, 55, 0, 0, 56, 77, 348, 16, 0,
17, 18, 19, 20, 21, 22, 23, 80, 0, 0,
24, 25, 26, 27, 28, 0, 29, 30, 31, 32,
33, 34, 81, 98, 82, 83, 35, 84, 85, 86,
87, 88, 89, 0, 0, 0, 90, 91, 92, 93,
36, 0, 37, 38, 39, 40, 41, 42, 0, 0,
- 0, 0, 43, 44, 45, 46, 47, 48, 49, 180,
- 181, 182, 183, 0, 0, 184, 50, 1, 2, 3,
- 4, 5, 6, 0, 0, 0, 0, 0, 51, 52,
+ 0, 0, 43, 44, 45, 46, 47, 48, 49, 1,
+ 2, 3, 4, 5, 6, 0, 50, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 51, 52,
53, 0, 0, 79, 0, 0, 54, 55, 0, 0,
56, 77, 447, 16, 0, 17, 18, 19, 20, 21,
22, 23, 80, 0, 0, 24, 25, 26, 27, 28,
50, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 51, 52, 53, 79, 0, 0, 0, 0,
54, 55, 0, 0, 56, 16, 0, 17, 18, 19,
- 20, 21, 22, 23, -67, 0, 0, 24, 25, 26,
+ 20, 21, 22, 23, -69, 0, 0, 24, 25, 26,
27, 28, 0, 29, 30, 31, 32, 33, 34, 0,
0, 0, 0, 35, 0, 0, 0, 0, 0, 0,
- 167, 168, 169, 170, 0, 0, 0, 36, 0, 37,
+ 0, 167, 168, 169, 170, 0, 0, 36, 0, 37,
38, 39, 40, 41, 42, 0, 0, 0, 0, 43,
- 44, 45, 46, 47, 48, 49, 176, 177, 178, 179,
- 0, 0, 0, 50, 180, 181, 182, 183, 0, 0,
- 184, 0, 0, 0, 0, 51, 52, 53, 79, 0,
- 0, 0, 0, 54, 55, 169, 170, 56, 16, 0,
+ 44, 45, 46, 47, 48, 49, 175, 176, 177, 178,
+ 179, 0, 0, 50, 0, 180, 181, 182, 183, 0,
+ 0, 184, 0, 0, 0, 51, 52, 53, 79, 0,
+ 0, 0, 0, 54, 55, 0, 0, 56, 16, 0,
17, 18, 19, 20, 21, 22, 23, 0, 0, 0,
24, 25, 26, 27, 28, 0, 29, 30, 31, 32,
- 33, 34, 179, 0, 0, 0, 35, 180, 181, 182,
- 183, 0, 0, 184, 0, 0, 0, 0, 0, 0,
+ 33, 34, 0, 0, 0, 0, 35, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
36, 0, 37, 38, 39, 40, 41, 42, 0, 0,
- -169, 0, 43, 44, 45, 46, 47, 48, 49, 186,
- 0, 187, -169, 0, 0, 0, 50, 0, 0, 0,
- -169, 0, 0, 0, 0, 0, 0, 0, 51, 52,
- 53, 167, 168, 169, 170, 0, 54, 55, 0, -67,
- 56, 0, -169, -169, -169, -169, 0, 0, 0, -169,
- 0, -169, 0, 0, -169, 0, 0, 0, 177, 178,
- 179, -169, -169, -169, -169, 180, 181, 182, 183, 0,
- 0, 184, 0, 0, 0, 0, -169, -169, -169, -208,
- -169, -169, -169, -169, -169, -169, -169, -169, -169, -169,
- -169, -208, 0, 0, 0, -169, -169, -169, -169, -208,
- 0, -169, -169, 0, 0, 0, 0, 0, 0, 0,
+ -171, 0, 43, 44, 45, 46, 47, 48, 49, 186,
+ 0, 187, -171, 0, 0, 0, 50, 0, 0, 0,
+ -171, 0, 0, 0, 0, 0, 0, 0, 51, 52,
+ 53, 167, 168, 169, 170, 0, 54, 55, 0, -69,
+ 56, 0, -171, -171, -171, -171, 0, 0, 0, -171,
+ 0, -171, 0, 0, -171, 0, 0, 176, 177, 178,
+ 179, -171, -171, -171, -171, 180, 181, 182, 183, 0,
+ 0, 184, 0, 0, 0, 0, -171, -171, -171, -210,
+ -171, -171, -171, -171, -171, -171, -171, -171, -171, -171,
+ -171, -210, 0, 0, 0, -171, -171, -171, -171, -210,
+ 0, -171, -171, 0, 0, 0, 0, 0, 0, 0,
167, 168, 169, 170, 0, 0, 0, 0, 0, 0,
- 0, -208, -208, -208, -208, 0, 0, 0, -208, 0,
- -208, 0, 0, -208, 0, 0, 0, 0, 178, 179,
- -208, -208, -208, -208, 180, 181, 182, 183, 0, 0,
- 184, 0, 0, 0, 0, -208, -208, -208, 0, -208,
- -208, -208, -208, -208, -208, -208, -208, -208, -208, -208,
- 0, 0, 0, 0, -208, -208, -208, -208, 0, 0,
- -208, -208, 77, 0, 16, 0, 17, 18, 19, 20,
+ 0, -210, -210, -210, -210, 0, 0, 0, -210, 0,
+ -210, 0, 0, -210, 0, 0, 0, 177, 178, 179,
+ -210, -210, -210, -210, 180, 181, 182, 183, 0, 0,
+ 184, 0, 0, 0, 0, -210, -210, -210, 0, -210,
+ -210, -210, -210, -210, -210, -210, -210, -210, -210, -210,
+ 0, 0, 0, 0, -210, -210, -210, -210, 0, 0,
+ -210, -210, 77, 0, 16, 0, 17, 18, 19, 20,
21, 22, 23, 0, 0, 0, 131, 25, 26, 27,
28, 109, 29, 30, 31, 32, 33, 34, 0, 0,
- 0, 0, 35, 0, 0, 0, 0, 0, 0, -236,
- 0, 169, 170, 0, 0, 0, 36, 0, 37, 38,
+ 0, 0, 35, 0, 0, 0, 0, 0, 0, 167,
+ -238, 169, 170, 0, 0, 0, 36, 0, 37, 38,
39, 40, 41, 42, 0, 0, 0, 0, 43, 44,
45, 46, 47, 48, 49, 0, 0, 178, 179, 0,
0, 0, 50, 180, 181, 182, 183, 0, 0, 184,
18, 19, 20, 21, 22, 23, 0, 0, 0, 24,
25, 26, 27, 28, 0, 29, 30, 31, 32, 33,
34, 0, 0, 0, 0, 35, 0, 0, 0, 0,
- 0, 0, 0, 0, 169, 170, 0, 0, 0, 36,
+ 0, 0, 167, 168, 169, 170, 0, 0, 0, 36,
0, 37, 38, 39, 40, 41, 42, 0, 0, 0,
0, 43, 44, 45, 46, 47, 48, 49, 0, 0,
178, 179, 0, 0, 0, 50, 180, 181, 182, 183,
16, 104, 17, 18, 19, 20, 21, 22, 23, 0,
0, 0, 24, 25, 26, 27, 28, 0, 29, 30,
31, 32, 33, 34, 0, 0, 0, 0, 35, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, -238, 0, 169, 170, 0,
0, 0, 36, 0, 37, 38, 39, 40, 41, 42,
0, 0, 0, 0, 43, 44, 45, 46, 47, 48,
- 49, 0, 0, 0, 0, 0, 0, 0, 50, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 49, 0, 0, 178, 179, 0, 0, 0, 50, 180,
+ 181, 182, 183, 0, 0, 184, 0, 0, 0, 0,
51, 52, 53, 0, 0, 0, 0, 0, 54, 55,
0, 16, 56, 17, 18, 19, 20, 21, 22, 23,
139, 0, 0, 24, 25, 26, 27, 28, 0, 29,
183, 0, 0, 184
};
-#define yypact_value_is_default(Yystate) \
- (!!((Yystate) == (-408)))
-
-#define yytable_value_is_error(Yytable_value) \
- (!!((Yytable_value) == (-236)))
-
static const yytype_int16 yycheck[] =
{
- 10, 11, 12, 15, 128, 0, 9, 117, 299, 42,
- 12, 418, 299, 16, 301, 302, 15, 50, 11, 396,
- 9, 12, 11, 20, 9, 12, 76, 77, 78, 9,
+ 10, 11, 12, 15, 128, 299, 9, 117, 396, 42,
+ 418, 9, 299, 16, 301, 302, 15, 50, 11, 0,
+ 9, 12, 11, 20, 9, 12, 76, 77, 78, 103,
8, 41, 80, 143, 44, 20, 103, 19, 20, 21,
22, 23, 45, 25, 26, 20, 21, 22, 23, 103,
- 25, 26, 102, 56, 102, 15, 16, 17, 20, 11,
- 42, 43, 103, 470, 26, 442, 48, 42, 43, 46,
- 47, 70, 12, 23, 76, 77, 78, 103, 28, 76,
+ 25, 26, 102, 56, 102, 15, 16, 17, 20, 9,
+ 42, 43, 470, 11, 26, 15, 48, 42, 43, 23,
+ 9, 70, 12, 23, 28, 463, 46, 47, 28, 76,
77, 78, 369, 93, 117, 76, 77, 78, 98, 76,
- 77, 78, 102, 103, 20, 103, 17, 18, 222, 77,
- 23, 80, 135, 12, 103, 98, 12, 9, 90, 12,
- 143, 32, 399, 123, 103, 36, 9, 120, 11, 9,
- 41, 20, 103, 44, 127, 128, 47, 12, 49, 103,
+ 77, 78, 102, 103, 103, 103, 17, 18, 222, 77,
+ 80, 9, 135, 12, 103, 98, 12, 9, 90, 11,
+ 143, 32, 399, 123, 103, 36, 9, 120, 11, 20,
+ 41, 48, 20, 44, 127, 128, 47, 12, 49, 23,
51, 52, 53, 54, 55, 12, 76, 77, 78, 20,
- 103, 48, 145, 103, 103, 9, 128, 11, 103, 20,
- 76, 77, 78, 128, 103, 20, 159, 160, 161, 103,
- 163, 164, 165, 454, 9, 452, 11, 76, 77, 78,
- 76, 77, 78, 76, 77, 78, 20, 76, 77, 78,
- 20, 193, 185, 186, 187, 188, 189, 190, 191, 192,
- 223, 76, 77, 78, 102, 76, 77, 78, 208, 76,
+ 103, 12, 145, 103, 103, 9, 128, 76, 77, 78,
+ 103, 15, 12, 128, 18, 20, 159, 160, 161, 23,
+ 163, 164, 165, 26, 28, 452, 103, 76, 77, 78,
+ 76, 77, 78, 102, 468, 76, 77, 78, 76, 77,
+ 78, 193, 185, 186, 187, 188, 189, 190, 191, 192,
+ 223, 76, 77, 78, 10, 76, 77, 78, 208, 76,
77, 78, 184, 103, 314, 76, 77, 78, 211, 212,
- 213, 214, 215, 216, 26, 339, 76, 77, 78, 222,
+ 213, 214, 215, 216, 103, 339, 76, 77, 78, 222,
198, 199, 200, 201, 202, 203, 102, 205, 206, 9,
- 233, 11, 76, 77, 78, 10, 76, 77, 78, 242,
- 72, 162, 102, 11, 23, 166, 167, 168, 169, 170,
+ 233, 11, 20, 103, 76, 77, 78, 103, 9, 242,
+ 11, 162, 72, 102, 20, 166, 167, 168, 169, 170,
171, 172, 173, 174, 175, 176, 177, 178, 179, 180,
- 9, 9, 11, 11, 267, 268, 9, 15, 16, 17,
- 18, 19, 15, 276, 103, 18, 24, 295, 288, 297,
- 23, 314, 23, 72, 394, 28, 102, 269, 76, 77,
- 78, 294, 295, 296, 297, 398, 299, 400, 301, 302,
- 403, 404, 76, 77, 78, 10, 61, 62, 63, 64,
- 26, 414, 415, 11, 102, 420, 298, 65, 78, 422,
- 103, 324, 300, 42, 43, 44, 45, 18, 433, 434,
- 49, 18, 51, 436, 89, 90, 339, 440, 443, 18,
- 95, 96, 97, 98, 18, 18, 101, 23, 453, 21,
- 61, 62, 63, 64, 15, 103, 102, 76, 77, 78,
- 26, 394, 10, 10, 467, 468, 369, 76, 77, 78,
- 10, 349, 10, 10, 352, 86, 87, 88, 89, 90,
- 76, 77, 78, 102, 95, 96, 97, 98, 23, 102,
- 101, 103, 102, 102, 102, 54, 399, 20, 401, 102,
- 412, 102, 61, 62, 63, 64, 102, 328, 102, 42,
- 43, 44, 45, 102, 426, 103, 49, 10, 51, 102,
- 20, 431, 9, 435, 102, 84, 85, 86, 87, 88,
- 89, 90, 9, 74, 20, 445, 95, 96, 97, 98,
- 450, 20, 101, 76, 77, 78, 102, 0, 1, 452,
- 96, 97, 98, 465, 20, 101, 9, 102, 11, 469,
- 13, 14, 15, 16, 17, 18, 19, 20, 22, 103,
- 23, 24, 25, 26, 27, 73, 29, 30, 31, 32,
+ 102, 9, 11, 11, 267, 268, 23, 15, 16, 17,
+ 18, 19, 9, 276, 11, 103, 24, 20, 288, 23,
+ 63, 314, 72, 102, 394, 10, 26, 269, 76, 77,
+ 78, 294, 295, 296, 297, 295, 299, 297, 301, 302,
+ 76, 77, 78, 398, 11, 400, 78, 90, 403, 404,
+ 18, 103, 95, 96, 97, 98, 298, 65, 101, 414,
+ 415, 324, 300, 42, 43, 44, 45, 422, 18, 18,
+ 49, 18, 51, 76, 77, 78, 339, 76, 77, 78,
+ 18, 436, 21, 63, 64, 440, 23, 76, 77, 78,
+ 76, 77, 78, 63, 64, 103, 102, 76, 77, 78,
+ 15, 394, 26, 102, 10, 10, 369, 10, 10, 89,
+ 90, 349, 467, 102, 352, 95, 96, 97, 98, 474,
+ 90, 101, 10, 102, 23, 95, 96, 97, 98, 102,
+ 102, 101, 96, 97, 98, 54, 399, 101, 103, 102,
+ 412, 102, 61, 62, 63, 64, 102, 328, 20, 102,
+ 42, 43, 44, 45, 426, 103, 102, 49, 421, 51,
+ 10, 431, 102, 435, 20, 84, 85, 86, 87, 88,
+ 89, 90, 9, 102, 9, 445, 95, 96, 97, 98,
+ 450, 74, 101, 103, 76, 77, 78, 0, 1, 452,
+ 20, 20, 102, 465, 102, 20, 9, 73, 11, 469,
+ 13, 14, 15, 16, 17, 18, 19, 20, 22, 12,
+ 23, 24, 25, 26, 27, 102, 29, 30, 31, 32,
33, 34, 35, 36, 37, 38, 39, 40, 41, 42,
- 43, 44, 45, 102, 102, 63, 49, 50, 51, 52,
- 53, 12, 55, 56, 57, 58, 59, 60, 98, 76,
- 77, 78, 65, 66, 67, 68, 69, 70, 71, 76,
- 77, 78, 90, 401, 454, 195, 79, 95, 96, 97,
- 98, 35, 83, 101, 351, 102, 392, 411, 91, 92,
- 93, 48, 0, 1, -1, 102, 99, 100, 48, -1,
+ 43, 44, 45, 76, 77, 78, 49, 50, 51, 52,
+ 53, 102, 55, 56, 57, 58, 59, 60, 420, 76,
+ 77, 78, 65, 66, 67, 68, 69, 70, 71, 102,
+ 98, 433, 434, 468, 421, 195, 79, 95, 96, 97,
+ 98, 443, 35, 101, 83, 102, 351, 392, 91, 92,
+ 93, 453, 0, 1, 411, -1, 99, 100, 48, 48,
103, 9, -1, 11, -1, 13, 14, 15, 16, 17,
18, 19, 20, -1, -1, 23, 24, 25, 26, 27,
-1, 29, 30, 31, 32, 33, 34, 35, 36, 37,
38, 39, 40, 41, 42, 43, 44, 45, -1, -1,
-1, 49, 50, 51, 52, 53, -1, 55, 56, 57,
58, 59, 60, -1, -1, -1, -1, 65, 66, 67,
- 68, 69, 70, 71, -1, -1, -1, 9, -1, 90,
- -1, 79, -1, 15, 95, 96, 97, 98, -1, -1,
- 101, 23, -1, 91, 92, 93, 28, -1, 1, -1,
+ 68, 69, 70, 71, -1, -1, -1, 90, -1, -1,
+ -1, 79, 95, 96, 97, 98, -1, -1, 101, -1,
+ -1, -1, -1, 91, 92, 93, -1, -1, 1, -1,
-1, 99, 100, -1, -1, 103, 9, 10, 11, -1,
13, 14, 15, 16, 17, 18, 19, 20, -1, -1,
23, 24, 25, 26, 27, -1, 29, 30, 31, 32,
33, 34, 35, 36, 37, 38, 39, 40, 41, 42,
43, 44, 45, -1, -1, -1, 49, 50, 51, 52,
53, -1, 55, 56, 57, 58, 59, 60, -1, -1,
- -1, -1, 65, 66, 67, 68, 69, 70, 71, 95,
- 96, 97, 98, -1, -1, 101, 79, 3, 4, 5,
- 6, 7, 8, -1, -1, -1, -1, -1, 91, 92,
+ -1, -1, 65, 66, 67, 68, 69, 70, 71, 3,
+ 4, 5, 6, 7, 8, -1, 79, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 91, 92,
93, -1, -1, 1, -1, -1, 99, 100, -1, -1,
103, 9, 10, 11, -1, 13, 14, 15, 16, 17,
18, 19, 20, -1, -1, 23, 24, 25, 26, 27,
16, 17, 18, 19, 20, -1, -1, 23, 24, 25,
26, 27, -1, 29, 30, 31, 32, 33, 34, -1,
-1, -1, -1, 39, -1, -1, -1, -1, -1, -1,
- 61, 62, 63, 64, -1, -1, -1, 53, -1, 55,
+ -1, 61, 62, 63, 64, -1, -1, 53, -1, 55,
56, 57, 58, 59, 60, -1, -1, -1, -1, 65,
- 66, 67, 68, 69, 70, 71, 87, 88, 89, 90,
- -1, -1, -1, 79, 95, 96, 97, 98, -1, -1,
- 101, -1, -1, -1, -1, 91, 92, 93, 1, -1,
- -1, -1, -1, 99, 100, 63, 64, 103, 11, -1,
+ 66, 67, 68, 69, 70, 71, 86, 87, 88, 89,
+ 90, -1, -1, 79, -1, 95, 96, 97, 98, -1,
+ -1, 101, -1, -1, -1, 91, 92, 93, 1, -1,
+ -1, -1, -1, 99, 100, -1, -1, 103, 11, -1,
13, 14, 15, 16, 17, 18, 19, -1, -1, -1,
23, 24, 25, 26, 27, -1, 29, 30, 31, 32,
- 33, 34, 90, -1, -1, -1, 39, 95, 96, 97,
- 98, -1, -1, 101, -1, -1, -1, -1, -1, -1,
+ 33, 34, -1, -1, -1, -1, 39, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
53, -1, 55, 56, 57, 58, 59, 60, -1, -1,
0, -1, 65, 66, 67, 68, 69, 70, 71, 9,
-1, 11, 12, -1, -1, -1, 79, -1, -1, -1,
20, -1, -1, -1, -1, -1, -1, -1, 91, 92,
93, 61, 62, 63, 64, -1, 99, 100, -1, 102,
103, -1, 42, 43, 44, 45, -1, -1, -1, 49,
- -1, 51, -1, -1, 54, -1, -1, -1, 88, 89,
+ -1, 51, -1, -1, 54, -1, -1, 87, 88, 89,
90, 61, 62, 63, 64, 95, 96, 97, 98, -1,
-1, 101, -1, -1, -1, -1, 76, 77, 78, 0,
80, 81, 82, 83, 84, 85, 86, 87, 88, 89,
-1, 101, 102, -1, -1, -1, -1, -1, -1, -1,
61, 62, 63, 64, -1, -1, -1, -1, -1, -1,
-1, 42, 43, 44, 45, -1, -1, -1, 49, -1,
- 51, -1, -1, 54, -1, -1, -1, -1, 89, 90,
+ 51, -1, -1, 54, -1, -1, -1, 88, 89, 90,
61, 62, 63, 64, 95, 96, 97, 98, -1, -1,
101, -1, -1, -1, -1, 76, 77, 78, -1, 80,
81, 82, 83, 84, 85, 86, 87, 88, 89, 90,
17, 18, 19, -1, -1, -1, 23, 24, 25, 26,
27, 28, 29, 30, 31, 32, 33, 34, -1, -1,
-1, -1, 39, -1, -1, -1, -1, -1, -1, 61,
- -1, 63, 64, -1, -1, -1, 53, -1, 55, 56,
+ 62, 63, 64, -1, -1, -1, 53, -1, 55, 56,
57, 58, 59, 60, -1, -1, -1, -1, 65, 66,
67, 68, 69, 70, 71, -1, -1, 89, 90, -1,
-1, -1, 79, 95, 96, 97, 98, -1, -1, 101,
14, 15, 16, 17, 18, 19, -1, -1, -1, 23,
24, 25, 26, 27, -1, 29, 30, 31, 32, 33,
34, -1, -1, -1, -1, 39, -1, -1, -1, -1,
- -1, -1, -1, -1, 63, 64, -1, -1, -1, 53,
+ -1, -1, 61, 62, 63, 64, -1, -1, -1, 53,
-1, 55, 56, 57, 58, 59, 60, -1, -1, -1,
-1, 65, 66, 67, 68, 69, 70, 71, -1, -1,
89, 90, -1, -1, -1, 79, 95, 96, 97, 98,
11, 12, 13, 14, 15, 16, 17, 18, 19, -1,
-1, -1, 23, 24, 25, 26, 27, -1, 29, 30,
31, 32, 33, 34, -1, -1, -1, -1, 39, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 61, -1, 63, 64, -1,
-1, -1, 53, -1, 55, 56, 57, 58, 59, 60,
-1, -1, -1, -1, 65, 66, 67, 68, 69, 70,
- 71, -1, -1, -1, -1, -1, -1, -1, 79, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 71, -1, -1, 89, 90, -1, -1, -1, 79, 95,
+ 96, 97, 98, -1, -1, 101, -1, -1, -1, -1,
91, 92, 93, -1, -1, -1, -1, -1, 99, 100,
-1, 11, 103, 13, 14, 15, 16, 17, 18, 19,
20, -1, -1, 23, 24, 25, 26, 27, -1, 29,
16, 17, 18, 19, 23, 24, 25, 26, 27, 29,
30, 31, 32, 33, 34, 39, 53, 55, 56, 57,
58, 59, 60, 65, 66, 67, 68, 69, 70, 71,
- 79, 91, 92, 93, 99, 100, 103, 149, 150, 151,
- 154, 155, 156, 157, 158, 159, 161, 164, 166, 167,
- 168, 169, 170, 171, 172, 173, 174, 9, 112, 1,
+ 79, 91, 92, 93, 99, 100, 103, 151, 152, 153,
+ 156, 157, 158, 159, 160, 161, 163, 166, 168, 169,
+ 170, 171, 172, 173, 174, 175, 176, 9, 112, 1,
20, 35, 37, 38, 40, 41, 42, 43, 44, 45,
- 49, 50, 51, 52, 112, 121, 127, 149, 36, 119,
- 120, 121, 117, 117, 12, 149, 159, 159, 23, 28,
- 112, 167, 175, 175, 175, 175, 175, 175, 175, 160,
- 11, 103, 159, 139, 139, 159, 103, 103, 103, 112,
- 159, 23, 150, 163, 167, 175, 175, 112, 159, 20,
- 149, 23, 28, 141, 159, 103, 162, 167, 168, 169,
- 159, 150, 159, 159, 159, 159, 159, 102, 149, 76,
+ 49, 50, 51, 52, 112, 121, 129, 151, 36, 119,
+ 120, 121, 117, 117, 12, 151, 161, 161, 23, 28,
+ 112, 169, 177, 177, 177, 177, 177, 177, 177, 162,
+ 11, 103, 161, 141, 141, 161, 103, 103, 103, 112,
+ 161, 23, 152, 165, 169, 177, 177, 112, 161, 20,
+ 151, 23, 28, 143, 161, 103, 164, 169, 170, 171,
+ 161, 152, 161, 161, 161, 161, 161, 102, 151, 76,
77, 78, 80, 9, 11, 103, 54, 61, 62, 63,
64, 81, 82, 84, 85, 86, 87, 88, 89, 90,
95, 96, 97, 98, 101, 103, 9, 11, 9, 11,
- 9, 11, 9, 114, 140, 141, 23, 138, 103, 103,
- 103, 103, 70, 103, 167, 103, 103, 112, 48, 129,
+ 9, 11, 9, 114, 142, 143, 23, 140, 103, 103,
+ 103, 103, 70, 103, 169, 103, 103, 112, 48, 131,
20, 42, 43, 44, 45, 49, 51, 120, 121, 119,
- 12, 163, 103, 103, 149, 102, 112, 26, 142, 102,
- 102, 149, 164, 175, 150, 10, 20, 163, 102, 149,
- 72, 144, 11, 102, 149, 149, 149, 159, 149, 149,
- 102, 149, 159, 159, 159, 159, 159, 159, 159, 159,
- 159, 159, 159, 159, 159, 159, 159, 9, 11, 15,
- 16, 17, 18, 19, 24, 65, 103, 153, 167, 102,
- 149, 149, 149, 149, 149, 149, 149, 149, 117, 23,
- 137, 138, 23, 123, 114, 114, 114, 114, 114, 114,
- 103, 114, 114, 112, 149, 133, 149, 149, 149, 149,
- 149, 164, 150, 12, 152, 72, 143, 102, 102, 149,
- 10, 102, 26, 149, 11, 20, 12, 102, 83, 149,
- 149, 18, 18, 18, 18, 18, 18, 102, 149, 103,
+ 12, 165, 103, 103, 151, 102, 112, 26, 144, 102,
+ 102, 151, 166, 177, 152, 10, 20, 165, 102, 151,
+ 72, 146, 11, 102, 151, 151, 151, 161, 151, 151,
+ 102, 151, 161, 161, 161, 161, 161, 161, 161, 161,
+ 161, 161, 161, 161, 161, 161, 161, 9, 11, 15,
+ 16, 17, 18, 19, 24, 65, 103, 155, 169, 102,
+ 151, 151, 151, 151, 151, 151, 151, 151, 117, 23,
+ 139, 140, 23, 123, 114, 114, 114, 114, 114, 114,
+ 103, 114, 114, 112, 151, 135, 151, 151, 151, 151,
+ 151, 166, 152, 12, 154, 72, 145, 102, 102, 151,
+ 10, 102, 26, 151, 11, 20, 12, 102, 83, 151,
+ 151, 18, 18, 18, 18, 18, 18, 102, 151, 103,
102, 20, 12, 20, 12, 20, 12, 20, 10, 21,
- 113, 122, 9, 20, 23, 132, 149, 133, 134, 149,
- 133, 136, 165, 167, 127, 131, 134, 135, 149, 114,
- 134, 134, 102, 102, 163, 26, 114, 147, 102, 12,
- 149, 10, 159, 20, 12, 102, 164, 10, 10, 10,
- 10, 114, 142, 114, 23, 102, 102, 102, 102, 103,
- 102, 20, 134, 102, 102, 103, 145, 12, 10, 102,
- 20, 143, 124, 163, 130, 130, 9, 115, 115, 134,
- 115, 132, 102, 115, 115, 146, 9, 74, 20, 147,
- 148, 117, 20, 115, 115, 116, 46, 47, 128, 128,
- 102, 129, 20, 115, 102, 117, 118, 10, 129, 129,
- 117, 115, 103, 115, 130, 129, 10, 20, 26, 125,
- 10, 134, 129, 135, 22, 73, 126, 102, 102, 117,
- 115, 115, 74, 128
+ 113, 122, 9, 20, 23, 134, 151, 135, 136, 151,
+ 135, 138, 167, 169, 129, 133, 136, 137, 151, 114,
+ 136, 136, 102, 102, 165, 26, 114, 149, 102, 12,
+ 151, 10, 161, 20, 12, 102, 166, 10, 10, 10,
+ 10, 114, 144, 114, 23, 102, 102, 102, 102, 103,
+ 102, 20, 136, 102, 102, 103, 147, 12, 10, 102,
+ 20, 145, 126, 165, 132, 132, 9, 115, 115, 136,
+ 115, 124, 102, 115, 115, 148, 9, 74, 20, 149,
+ 150, 117, 20, 115, 115, 116, 46, 47, 130, 130,
+ 102, 131, 134, 115, 102, 117, 118, 10, 131, 131,
+ 117, 115, 103, 115, 20, 131, 10, 20, 26, 127,
+ 10, 136, 131, 125, 22, 73, 128, 102, 132, 117,
+ 115, 137, 74, 130, 102, 115
};
typedef enum {
toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
- toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
- toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_ival, toketype_opval,
+ toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival,
+ toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_ival, toketype_opval,
toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_opval,
- toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival,
- toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival,
- toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
+ toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval,
+ toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
+ toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_ival,
+ toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
+ toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
+ toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval,
toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval,
- toketype_opval, toketype_opval, toketype_opval, toketype_opval
+ toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval
};
/* Generated from:
- * 7e6c275bbd1dbc800c205a8a8b0cd785e4859f94976ee7372149598471f16f81 perly.y
+ * 39b6174c4729deec2a6ee4698d7dcd6496acb0a8f063daf726d1f853d4dcb54e perly.y
* d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl
* ex: set ro: */
/* Top-level choice of what kind of thing yyparse was called to parse */
grammar : GRAMPROG
{
- PL_parser->expect = XSTATE;
+ parser->expect = XSTATE;
}
remember stmtseq
{
/* An ordinary block */
block : '{' remember stmtseq '}'
- { if (PL_parser->copline > (line_t)$1)
- PL_parser->copline = (line_t)$1;
+ { if (parser->copline > (line_t)$1)
+ parser->copline = (line_t)$1;
$$ = block_end($2, $3);
}
;
/* format body */
formblock: '=' remember ';' FORMRBRACK formstmtseq ';' '.'
- { if (PL_parser->copline > (line_t)$1)
- PL_parser->copline = (line_t)$1;
+ { if (parser->copline > (line_t)$1)
+ parser->copline = (line_t)$1;
$$ = block_end($2, $5);
}
;
;
mblock : '{' mremember stmtseq '}'
- { if (PL_parser->copline > (line_t)$1)
- PL_parser->copline = (line_t)$1;
+ { if (parser->copline > (line_t)$1)
+ parser->copline = (line_t)$1;
$$ = block_end($2, $3);
}
;
CvOUTSIDE(PL_compcv)
))[$2->op_targ]))
CvCLONE_on(PL_compcv);
- PL_parser->in_my = 0;
- PL_parser->in_my_stash = NULL;
+ parser->in_my = 0;
+ parser->in_my_stash = NULL;
}
proto subattrlist optsubbody
{
{
$$ = block_end($3,
newCONDOP(0, $4, op_scope($6), $7));
- PL_parser->copline = (line_t)$1;
+ parser->copline = (line_t)$1;
}
| UNLESS '(' remember miexpr ')' mblock else
{
$$ = block_end($3,
newCONDOP(0, $4, op_scope($6), $7));
- PL_parser->copline = (line_t)$1;
+ parser->copline = (line_t)$1;
}
| GIVEN '(' remember mexpr ')' mblock
{
|| PAD_COMPNAME_FLAGS_isOUR(offset)
? 0
: offset));
- PL_parser->copline = (line_t)$1;
+ parser->copline = (line_t)$1;
}
| WHEN '(' remember mexpr ')' mblock
{ $$ = block_end($3, newWHENOP($4, op_scope($6))); }
$$ = block_end($3,
newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
$4, $7, $8, $6));
- PL_parser->copline = (line_t)$1;
+ parser->copline = (line_t)$1;
}
| UNTIL '(' remember iexpr ')' mintro mblock cont
{
$$ = block_end($3,
newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
$4, $7, $8, $6));
- PL_parser->copline = (line_t)$1;
+ parser->copline = (line_t)$1;
}
- | FOR '(' remember mnexpr ';' texpr ';' mintro mnexpr ')'
+ | FOR '(' remember mnexpr ';'
+ { parser->expect = XTERM; }
+ texpr ';'
+ { parser->expect = XTERM; }
+ mintro mnexpr ')'
mblock
{
OP *initop = $4;
OP *forop = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
- scalar($6), $11, $9, $8);
+ scalar($7), $13, $11, $10);
if (initop) {
forop = op_prepend_elem(OP_LINESEQ, initop,
op_append_elem(OP_LINESEQ,
forop));
}
$$ = block_end($3, forop);
- PL_parser->copline = (line_t)$1;
+ parser->copline = (line_t)$1;
}
| FOR MY remember my_scalar '(' mexpr ')' mblock cont
{
$$ = block_end($3, newFOROP(0, $4, $6, $8, $9));
- PL_parser->copline = (line_t)$1;
+ parser->copline = (line_t)$1;
}
| FOR scalar '(' remember mexpr ')' mblock cont
{
$$ = block_end($4, newFOROP(0,
op_lvalue($2, OP_ENTERLOOP), $5, $7, $8));
- PL_parser->copline = (line_t)$1;
+ parser->copline = (line_t)$1;
}
| FOR '(' remember mexpr ')' mblock cont
{
$$ = block_end($3,
newFOROP(0, (OP*)NULL, $4, $6, $7));
- PL_parser->copline = (line_t)$1;
+ parser->copline = (line_t)$1;
}
| block cont
{
/* a block is a loop that happens once */
$$ = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
(OP*)NULL, block_end($5, $7), (OP*)NULL, 0);
- if (PL_parser->copline > (line_t)$4)
- PL_parser->copline = (line_t)$4;
+ if (parser->copline > (line_t)$4)
+ parser->copline = (line_t)$4;
}
| sideff ';'
{
- PL_parser->expect = XSTATE;
$$ = $1;
}
| ';'
{
- PL_parser->expect = XSTATE;
$$ = (OP*)NULL;
- PL_parser->copline = NOLINE;
+ parser->copline = NOLINE;
}
;
else {
list = $1;
}
- if (PL_parser->copline == NOLINE)
- PL_parser->copline = CopLINE(PL_curcop)-1;
- else PL_parser->copline--;
+ if (parser->copline == NOLINE)
+ parser->copline = CopLINE(PL_curcop)-1;
+ else parser->copline--;
$$ = newSTATEOP(0, NULL,
convert(OP_FORMLINE, 0, list));
}
{ $$ = newLOOPOP(OPf_PARENS, 1, $3, $1); }
| expr FOR expr
{ $$ = newFOROP(0, (OP*)NULL, $3, $1, (OP*)NULL);
- PL_parser->copline = (line_t)$2; }
+ parser->copline = (line_t)$2; }
| expr WHEN expr
{ $$ = newWHENOP($3, op_scope($1)); }
;
$$ = op_scope($2);
}
| ELSIF '(' mexpr ')' mblock else
- { PL_parser->copline = (line_t)$1;
+ { parser->copline = (line_t)$1;
$$ = newCONDOP(0,
newSTATEOP(OPf_SPECIAL,NULL,$3),
op_scope($5), $6);
{
$$ = op_append_list(OP_LINESEQ, $<opval>2,
newSTATEOP(0, NULL, sawparens(newNULLLIST())));
- PL_parser->expect = XBLOCK;
+ parser->expect = XBLOCK;
}
;
/* Subroutine body - block with optional signature */
realsubbody: remember subsignature '{' stmtseq '}'
{
- if (PL_parser->copline > (line_t)$3)
- PL_parser->copline = (line_t)$3;
+ if (parser->copline > (line_t)$3)
+ parser->copline = (line_t)$3;
$$ = block_end($1,
op_append_list(OP_LINESEQ, $2, $4));
}
/* Optional subroutine body, for named subroutine declaration */
optsubbody: realsubbody { $$ = $1; }
- | ';' { $$ = (OP*)NULL;
- PL_parser->expect = XSTATE;
- }
+ | ';' { $$ = (OP*)NULL; }
;
/* Ordinary expressions; logical combinations */
subscripted: gelem '{' expr ';' '}' /* *main::{something} */
/* In this and all the hash accessors, ';' is
* provided by the tokeniser */
- { $$ = newBINOP(OP_GELEM, 0, $1, scalar($3));
- PL_parser->expect = XOPERATOR;
- }
+ { $$ = newBINOP(OP_GELEM, 0, $1, scalar($3)); }
| scalar '[' expr ']' /* $array[$element] */
{ $$ = newBINOP(OP_AELEM, 0, oopsAV($1), scalar($3));
}
}
| scalar '{' expr ';' '}' /* $foo{bar();} */
{ $$ = newBINOP(OP_HELEM, 0, oopsHV($1), jmaybe($3));
- PL_parser->expect = XOPERATOR;
}
| term ARROW '{' expr ';' '}' /* somehref->{bar();} */
{ $$ = newBINOP(OP_HELEM, 0,
ref(newHVREF($1),OP_RV2HV),
- jmaybe($4));
- PL_parser->expect = XOPERATOR;
- }
+ jmaybe($4)); }
| subscripted '{' expr ';' '}' /* $foo->[bar]->{baz;} */
{ $$ = newBINOP(OP_HELEM, 0,
ref(newHVREF($1),OP_RV2HV),
- jmaybe($3));
- PL_parser->expect = XOPERATOR;
- }
+ jmaybe($3)); }
| term ARROW '(' ')' /* $subref->() */
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar($1))); }
if ($$ && $1)
$$->op_private |=
$1->op_private & OPpSLICEWARNING;
- PL_parser->expect = XOPERATOR;
}
| kvslice '{' expr ';' '}' /* %hash{@keys} */
{ $$ = op_prepend_elem(OP_KVHSLICE,
if ($$ && $1)
$$->op_private |=
$1->op_private & OPpSLICEWARNING;
- PL_parser->expect = XOPERATOR;
}
| THING %prec '('
{ $$ = $1; }
/* A little bit of trickery to make "for my $foo (@bar)" actually be
lexical */
my_scalar: scalar
- { PL_parser->in_my = 0; $$ = my($1); }
+ { parser->in_my = 0; $$ = my($1); }
;
amper : '&' indirob
* 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.3" /**/
-#define PRIVLIB_EXP "/sys/lib/perl/5.21.3" /**/
+#define PRIVLIB "/sys/lib/perl/5.21.4" /**/
+#define PRIVLIB_EXP "/sys/lib/perl/5.21.4" /**/
/* 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.3/site_perl" /**/
-#define SITELIB_EXP "/sys/lib/perl/5.21.3/site_perl" /**/
-#define SITELIB_STEM "/sys/lib/perl/5.21.3/site_perl" /**/
+#define SITELIB "/sys/lib/perl/5.21.4/site_perl" /**/
+#define SITELIB_EXP "/sys/lib/perl/5.21.4/site_perl" /**/
+#define SITELIB_STEM "/sys/lib/perl/5.21.4/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='3'
+api_subversion='4'
api_version='21'
-api_versionstring='5.21.3'
+api_versionstring='5.21.4'
ar='ar'
-archlib='/sys/lib/perl5/5.21.3/386'
-archlibexp='/sys/lib/perl5/5.21.3/386'
+archlib='/sys/lib/perl5/5.21.4/386'
+archlibexp='/sys/lib/perl5/5.21.4/386'
archname64=''
archname='386'
archobjs=''
d__fwalk='undef'
d_access='define'
d_accessx='undef'
+d_acosh='undef'
d_aintl='undef'
d_alarm='define'
d_archlib='define'
d_fd_macros='undef'
d_fd_set='undef'
d_fds_bits='undef'
+d_fegetround='undef'
d_fgetpos='define'
d_finite='undef'
d_finitel='undef'
d_flockproto='undef'
d_fork='define'
d_fp_class='undef'
+d_fp_classify='undef'
+d_fp_classl='undef'
d_fpathconf='define'
d_fpclass='undef'
d_fpclassify='undef'
d_fpclassl='undef'
+d_fpgetround='undef'
d_fpos64_t='undef'
d_frexpl='undef'
d_fs_data_s='undef'
d_isascii='undef'
d_isblank='undef'
d_isfinite='undef'
+d_isfinitel='undef'
d_isinf='undef'
+d_isinfl='undef'
d_isnan='undef'
d_isnanl='undef'
+d_j0='undef'
+d_j0l='undef'
d_killpg='undef'
d_lchown='undef'
d_ldbl_dig='define'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
d_truncate='undef'
+d_truncl='undef'
d_ttyname_r='undef'
d_tzname='define'
d_u32align='define'
i_dlfcn='undef'
i_execinfo='undef'
i_fcntl='define'
+i_fenv='undef'
i_float='define'
i_fp='undef'
i_fp_class='undef'
i_prot='undef'
i_pthread='undef'
i_pwd='define'
+i_quadmath='undef'
i_rpcsvcdbm='undef'
i_sgtty='undef'
i_shadow='undef'
i_stdarg='define'
i_stdbool='undef'
i_stddef='define'
+i_stdint='undef'
i_stdlib='define'
i_string='define'
i_sunmath='undef'
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='/sys/lib/perl/5.21.3/386'
+installarchlib='/sys/lib/perl/5.21.4/386'
installbin='/usr/bin'
installman1dir='/sys/man/1pub'
installman3dir='/sys/man/2pub'
installprefix='/usr'
installprefixexp='/usr'
-installprivlib='/sys/lib/perl/5.21.3'
+installprivlib='/sys/lib/perl/5.21.4'
installscript='/usr/bin'
-installsitearch='/sys/lib/perl/5.21.3/site_perl/386'
+installsitearch='/sys/lib/perl/5.21.4/site_perl/386'
installsitebin='/usr/bin'
-installsitelib='/sys/lib/perl/5.21.3/site_perl'
+installsitelib='/sys/lib/perl/5.21.4/site_perl'
installstyle='lib/perl5'
installusrbinperl='undef'
installvendorarch=''
pr=''
prefix='/usr'
prefixexp='/usr'
-privlib='/sys/lib/perl/5.21.3'
-privlibexp='/sys/lib/perl/5.21.3'
+privlib='/sys/lib/perl/5.21.4'
+privlibexp='/sys/lib/perl/5.21.4'
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.3/site_perl/386'
+sitearch='/sys/lib/perl/5.21.4/site_perl/386'
sitearchexp='/sys/lib/perl/site_perl/386'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
-sitelib='/sys/lib/perl/5.21.3/site_perl'
-sitelib_stem='/sys/lib/perl/5.21.3/site_perl'
-sitelibexp='/sys/lib/perl/5.21.3/site_perl'
+sitelib='/sys/lib/perl/5.21.4/site_perl'
+sitelib_stem='/sys/lib/perl/5.21.4/site_perl'
+sitelibexp='/sys/lib/perl/5.21.4/site_perl'
siteprefix='/usr'
siteprefixexp='/usr'
sizesize='4'
strerror_r_proto='0'
strings='/sys/include/ape/string.h'
submit=''
-subversion='3'
+subversion='4'
sysman='/sys/man/1pub'
tail=''
tar=''
useopcode='true'
useperlio='define'
useposix='true'
+usequadmath='undef'
usereentrant='undef'
userelocatableinc='undef'
useshrplib='false'
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
-version='5.21.3'
-version_patchlevel_string='version 21 subversion 3'
+version='5.21.4'
+version_patchlevel_string='version 21 subversion 4'
versiononly='undef'
vi=''
xlibpth=''
config_argc=0
PERL_REVISION=5
PERL_VERSION=21
-PERL_SUBVERSION=3
+PERL_SUBVERSION=4
PERL_API_REVISION=5
PERL_API_VERSION=21
-PERL_API_SUBVERSION=3
+PERL_API_SUBVERSION=4
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
/roffitall
# generated
-/perl5213delta.pod
+/perl5214delta.pod
/perlapi.pod
/perlintern.pod
*.html
perlhist Perl history records
perldelta Perl changes since previous version
+ perl5213delta Perl changes in version 5.21.3
perl5212delta Perl changes in version 5.21.2
perl5211delta Perl changes in version 5.21.1
perl5210delta Perl changes in version 5.21.0
perl5200delta Perl changes in version 5.20.0
+ perl5201delta Perl changes in version 5.20.1
perl5182delta Perl changes in version 5.18.2
perl5181delta Perl changes in version 5.18.1
perl5180delta Perl changes in version 5.18.0
--- /dev/null
+=encoding utf8
+
+=head1 NAME
+
+perl5201delta - what is new for perl v5.20.1
+
+=head1 DESCRIPTION
+
+This document describes differences between the 5.20.0 release and the 5.20.1
+release.
+
+If you are upgrading from an earlier release such as 5.18.0, first read
+L<perl5200delta>, which describes differences between 5.18.0 and 5.20.0.
+
+=head1 Incompatible Changes
+
+There are no changes intentionally incompatible with 5.20.0. If any exist,
+they are bugs, and we request that you submit a report. See L</Reporting Bugs>
+below.
+
+=head1 Performance Enhancements
+
+=over 4
+
+=item *
+
+An optimization to avoid problems with COW and deliberately overallocated PVs
+has been disabled because it interfered with another, more important,
+optimization, causing a slowdown on some platforms.
+L<[perl #121975]|https://rt.perl.org/Ticket/Display.html?id=121975>
+
+=item *
+
+Returning a string from a lexical variable could be slow in some cases. This
+has now been fixed.
+L<[perl #121977]|https://rt.perl.org/Ticket/Display.html?id=121977>
+
+=back
+
+=head1 Modules and Pragmata
+
+=head2 Updated Modules and Pragmata
+
+=over 4
+
+=item *
+
+L<Config::Perl::V> has been upgraded from version 0.20 to 0.22.
+
+The list of Perl versions covered has been updated and some flaws in the
+parsing have been fixed.
+
+=item *
+
+L<Exporter> has been upgraded from version 5.70 to 5.71.
+
+Illegal POD syntax in the documentation has been corrected.
+
+=item *
+
+L<ExtUtils::CBuilder> has been upgraded from version 0.280216 to 0.280217.
+
+Android builds now link to both B<-lperl> and C<$Config::Config{perllibs}>.
+
+=item *
+
+L<File::Copy> has been upgraded from version 2.29 to 2.30.
+
+The documentation now notes that C<copy> will not overwrite read-only files.
+
+=item *
+
+L<Module::CoreList> has been upgraded from version 3.11 to 5.020001.
+
+The list of Perl versions covered has been updated.
+
+=item *
+
+The PathTools module collection has been upgraded from version 3.47 to 3.48.
+
+Fallbacks are now in place when cross-compiling for Android and
+C<$Config::Config{sh}> is not yet defined.
+L<[perl #121963]|https://rt.perl.org/Ticket/Display.html?id=121963>
+
+=item *
+
+L<PerlIO::via> has been upgraded from version 0.14 to 0.15.
+
+A minor portability improvement has been made to the XS implementation.
+
+=item *
+
+L<Unicode::UCD> has been upgraded from version 0.57 to 0.58.
+
+The documentation includes many clarifications and fixes.
+
+=item *
+
+L<utf8> has been upgraded from version 1.13 to 1.13_01.
+
+The documentation has some minor formatting improvements.
+
+=item *
+
+L<version> has been upgraded from version 0.9908 to 0.9909.
+
+External libraries and Perl may have different ideas of what the locale is.
+This is problematic when parsing version strings if the locale's numeric
+separator has been changed. Version parsing has been patched to ensure it
+handles the locales correctly.
+L<[perl #121930]|https://rt.perl.org/Ticket/Display.html?id=121930>
+
+=back
+
+=head1 Documentation
+
+=head2 Changes to Existing Documentation
+
+=head3 L<perlapi>
+
+=over 4
+
+=item *
+
+C<av_len> - Emphasize that this returns the highest index in the array, not the
+size of the array.
+L<[perl #120386]|https://rt.perl.org/Ticket/Display.html?id=120386>
+
+=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.
+
+=back
+
+=head3 L<perlfunc>
+
+=over 4
+
+=item *
+
+Clarify the meaning of C<-B> and C<-T>.
+
+=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<each>, C<keys> and C<values> may produce different orderings for
+tied hashes compared to other perl hashes.
+L<[perl #121404]|https://rt.perl.org/Ticket/Display.html?id=121404>
+
+=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>
+
+=item *
+
+Clarify the meaning of C<our>.
+L<[perl #122132]|https://rt.perl.org/Ticket/Display.html?id=122132>
+
+=back
+
+=head3 L<perlguts>
+
+=over 4
+
+=item *
+
+Explain various ways of modifying an existing SV's buffer.
+L<[perl #116925]|https://rt.perl.org/Ticket/Display.html?id=116925>
+
+=back
+
+=head3 L<perlpolicy>
+
+=over 4
+
+=item *
+
+We now have a code of conduct for the I<< p5p >> mailing list, as documented in
+L<< perlpolicy/STANDARDS OF CONDUCT >>.
+
+=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<perlsyn>
+
+=over 4
+
+=item *
+
+Mention the use of empty conditionals in C<for>/C<while> loops for infinite
+loops.
+
+=back
+
+=head3 L<perlxs>
+
+=over 4
+
+=item *
+
+Added a discussion of locale issues in XS code.
+
+=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 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.
+
+=back
+
+=head1 Configuration and Compilation
+
+=over 4
+
+=item *
+
+Building Perl no longer writes to the source tree when configured with
+F<Configure>'s B<-Dmksymlinks> option.
+L<[perl #121585]|https://rt.perl.org/Ticket/Display.html?id=121585>
+
+=back
+
+=head1 Platform Support
+
+=head2 Platform-Specific Notes
+
+=over 4
+
+=item Android
+
+Build support has been improved for cross-compiling in general and for Android
+in particular.
+
+=item OpenBSD
+
+Corrected architectures and version numbers used in configuration hints when
+building Perl.
+
+=item Solaris
+
+B<c99> options have been cleaned up, hints look for B<solstudio> as well as
+B<SUNWspro>, and support for native C<setenv> has been added.
+
+=item VMS
+
+An old bug in feature checking, mainly affecting pre-7.3 systems, has been
+fixed.
+
+=item Windows
+
+C<%I64d> is now being used instead of C<%lld> for MinGW.
+
+=back
+
+=head1 Internal Changes
+
+=over 4
+
+=item *
+
+Added L<perlapi/sync_locale>.
+Changing the program's locale should be avoided by XS code. Nevertheless,
+certain non-Perl libraries called from XS, such as C<Gtk> do so. When this
+happens, Perl needs to be told that the locale has changed. Use this function
+to do so, before returning to Perl.
+
+=back
+
+=head1 Selected Bug Fixes
+
+=over 4
+
+=item *
+
+A bug has been fixed where zero-length assertions and code blocks inside of a
+regex could cause C<pos> to see an incorrect value.
+L<[perl #122460]|https://rt.perl.org/Ticket/Display.html?id=122460>
+
+=item *
+
+Using C<s///e> on tainted utf8 strings could issue bogus "Malformed UTF-8
+character (unexpected end of string)" warnings. This has now been fixed.
+L<[perl #122148]|https://rt.perl.org/Ticket/Display.html?id=122148>
+
+=item *
+
+C<system> and friends should now work properly on more Android builds.
+
+Due to an oversight, the value specified through B<-Dtargetsh> to F<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 C<system>,
+C<exec> and backticks: the commands would end up looking for F</bin/sh> instead
+of F</system/bin/sh>, and so would fail for the vast majority of devices,
+leaving C<$!> as C<ENOENT>.
+
+=item *
+
+Many issues have been detected by L<Coverity|http://www.coverity.com/> and
+fixed.
+
+=back
+
+=head1 Acknowledgements
+
+Perl 5.20.1 represents approximately 4 months of development since Perl 5.20.0
+and contains approximately 12,000 lines of changes across 170 files from 36
+authors.
+
+Excluding auto-generated files, documentation and release tools, there were
+approximately 2,600 lines of changes to 110 .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.20.1:
+
+Aaron Crane, Abigail, Alberto Simões, Alexandr Ciornii, Alexandre (Midnite)
+Jousset, Andrew Fresh, Andy Dougherty, Brian Fraser, Chris 'BinGOs' Williams,
+Craig A. Berry, Daniel Dragan, David Golden, David Mitchell, H.Merijn Brand,
+James E Keenan, Jan Dubois, Jarkko Hietaniemi, John Peacock, kafka, Karen
+Etheridge, Karl Williamson, Lukas Mai, Matthew Horsfall, Michael Bunk, Peter
+Martini, Rafael Garcia-Suarez, Reini Urban, Ricardo Signes, Shirakata Kentaro,
+Smylers, Steve Hay, Thomas Sibley, Todd Rinaldo, Tony Cook, Vladimir Marek,
+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
--- /dev/null
+=encoding utf8
+
+=head1 NAME
+
+perl5213delta - what is new for perl v5.21.3
+
+=head1 DESCRIPTION
+
+This document describes differences between the 5.21.2 release and the 5.21.3
+release.
+
+If you are upgrading from an earlier release such as 5.21.1, first read
+L<perl5212delta>, which describes differences between 5.21.1 and 5.21.2.
+
+=head1 Core Enhancements
+
+=head2 C<defined(@array = LIST)> is no longer fatal
+
+In 5.21.1, C<defined(@array)> was made fatal. This has been relaxed
+to not die if the argument is assigning to an array.
+
+=head2 Floating point parsing has been improved
+
+Parsing and printing of floating point values has been improved.
+
+As a completely new feature, hexadecimal floating point literals
+(like 0x1.23p-4) are now supported, and they can be output with
+C<printf %a>.
+
+=head1 Security
+
+=head2 The L<Safe> module could allow outside packages to be replaced
+
+Critical bugfix: outside packages could be replaced. L<Safe> has
+been patched to 2.38 to address this.
+
+=head1 Incompatible Changes
+
+=head2 S<C<use UNIVERSAL '...'>> is now a fatal error
+
+Importing functions from C<UNIVERSAL> has been deprecated since v5.12, and
+is now a fatal error. S<C<"use UNIVERSAL">> without any arguments is still
+allowed.
+
+=head1 Modules and Pragmata
+
+=head2 Updated Modules and Pragmata
+
+=over 4
+
+=item *
+
+L<B::Debug> has been upgraded from version 1.19 to 1.21.
+
+=item *
+
+L<Config::Perl::V> has been upgraded from version 0.20 to 0.22.
+
+=item *
+
+L<CPAN::Meta> has been upgraded from version 2.141520 to 2.142060.
+
+=item *
+
+L<CPAN::Meta::Requirements> has been upgraded from version 2.125 to 2.126.
+
+=item *
+
+L<ExtUtils::CBuilder> was moved from F<dist> to F<cpan>.
+
+=item *
+
+L<ExtUtils::CBuilder> has been upgraded from version 0.280216 to 0.280217.
+
+=item *
+
+L<ExtUtils::Install> was moved from F<dist> to F<cpan>.
+
+=item *
+
+L<ExtUtils::Manifest> has been upgraded from version 1.64 to 1.65.
+It was also moved from F<dist> to F<cpan>.
+
+=item *
+
+L<HTTP::Tiny> has been upgraded from version 0.043 to 0.047.
+
+=item *
+
+L<IPC::Open3> has been upgraded from version 1.17 to 1.18.
+
+=item *
+
+L<Module::CoreList> has been upgraded from version 5.021002 to 5.021003.
+
+=item *
+
+L<Opcode> has been upgraded from version 1.27 to 1.28.
+
+=item *
+
+L<perl5db.pl> has been upgraded from version 1.45 to 1.46.
+
+=item *
+
+L<perlfaq> has been upgraded from version 5.0150044 to 5.0150045.
+
+=item *
+
+L<POSIX> has been upgraded from version 1.41 to 1.42.
+
+=item *
+
+L<Safe> has been upgraded from version 2.37 to 2.38.
+
+=item *
+
+L<Socket> has been upgraded from version 2.014 to 2.015.
+
+=item *
+
+L<Sys::Hostname> has been upgraded from version 1.18 to 1.19
+
+=item *
+
+L<UNIVERSAL> has been upgraded from version 1.11 to 1.12.
+
+=back
+
+=head1 Documentation
+
+=head2 Changes to Existing Documentation
+
+=head3 L<perlexperiment>
+
+=over 4
+
+=item *
+
+Added reference to L<feature>.
+
+=back
+
+=head3 L<perlguts>
+
+=over 4
+
+=item *
+
+Details on C level symbols and libperl.t added.
+
+=back
+
+=head3 L<perlhacktips>
+
+=over 4
+
+=item *
+
+Recommended replacements for tmpfile, atoi, strtol, and strtoul added.
+
+=back
+
+=head3 L<perlop>
+
+=over 4
+
+=item *
+
+ASCII v. EBCDIC clarifications added.
+
+=back
+
+=head3 L<perlsec>
+
+=over 4
+
+=item *
+
+Comments added on algorithmic complexity and tied hashes.
+
+=back
+
+=head3 L<perlvms>
+
+=over 4
+
+=item *
+
+Updated documentation on environment and shell interaction in VMS.
+
+=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<Hexadecimal float: internal error|perldiag/"Hexadecimal float: internal error">
+
+(F) Something went horribly bad in hexadecimal float handling.
+
+=item *
+
+L<Hexadecimal float: unsupported long double format|perldiag/"Hexadecimal float: unsupported long double format">
+
+(F) You have configured Perl to use long doubles but
+the internals of the long double format are unknown,
+therefore the hexadecimal float output is impossible.
+
+=back
+
+=head3 New Warnings
+
+=over 4
+
+=item *
+
+L<Hexadecimal float: exponent overflow|perldiag/"Hexadecimal float: exponent overflow">
+
+(W overflow) The hexadecimal floating point has larger exponent
+than the floating point supports.
+
+=item *
+
+L<Hexadecimal float: exponent underflow|perldiag/"Hexadecimal float: exponent underflow">
+
+(W overflow) The hexadecimal floating point has smaller exponent
+than the floating point supports.
+
+=item *
+
+L<Hexadecimal float: mantissa overflow|perldiag/"Hexadecimal float: mantissa overflow">
+
+(W overflow) The hexadecimal floating point literal had more bits in
+the mantissa (the part between the 0x and the exponent, also known as
+the fraction or the significand) than the floating point supports.
+
+=item *
+
+L<Hexadecimal float: precision loss|perldiag/"Hexadecimal float: precision loss">
+
+(W overflow) The hexadecimal floating point had internally more
+digits than could be output. This can be caused by unsupported
+long double formats, or by 64-bit integers not being available
+(needed to retrieve the digits under some configurations).
+
+=back
+
+=head2 Changes to Existing Diagnostics
+
+=over 4
+
+=item *
+
+C<require> with no argument or undef used to warn about a Null filename; now
+it dies with C<Missing or undefined argument to require>.
+
+=back
+
+=head1 Configuration and Compilation
+
+=over 4
+
+=item *
+
+MurmurHash64A and MurmurHash64B can now be configured as the internal hash
+function.
+
+=back
+
+=head1 Platform Support
+
+=head2 Platform-Specific Notes
+
+=over 4
+
+=item Android
+
+Build support has been improved for cross-compiling in general and for
+Android in particular.
+
+=item Solaris
+
+C<c99> options have been cleaned up, hints look for C<solstudio>
+as well as C<SUNWspro>, and support for native C<setenv> has been added.
+
+=item VMS
+
+C<finite>, C<finitel>, and C<isfinite> detection has been added to
+C<configure.com>, environment handling has had some minor changes, and
+a fix for legacy feature checking status.
+
+=item Windows
+
+C<%I64d> is now being used instead of C<%lld> for MinGW.
+
+=back
+
+=head1 Internal Changes
+
+=over 4
+
+=item *
+
+Added L<perlapi/sync_locale>.
+Changing the program's locale should be avoided by XS code. Nevertheless,
+certain non-Perl libraries called from XS, such as C<Gtk> do so. When this
+happens, Perl needs to be told that the locale has changed. Use this function
+to do so, before returning to Perl.
+
+=item *
+
+Added L<perlapi/grok_atou> as a safer replacement for atoi and strtol.
+
+=back
+
+=head1 Selected Bug Fixes
+
+=over 4
+
+=item *
+
+Failing to compile C<use Foo> in an eval could leave a spurious
+C<BEGIN> subroutine definition, which would produce a "Subroutine
+BEGIN redefined" warning on the next use of C<use>, or other C<BEGIN>
+block. [perl #122107]
+
+=item *
+
+C<method { BLOCK } ARGS> syntax now correctly parses the arguments if they
+begin with an opening brace. [perl #46947]
+
+=item *
+
+External libraries and Perl may have different ideas of what the locale is.
+This is problematic when parsing version strings if the locale's numeric
+separator has been changed. Version parsing has been patched to ensure
+it handles the locales correctly. [perl #121930]
+
+=item *
+
+A bug has been fixed where zero-length assertions and code blocks inside of a
+regex could cause C<pos> to see an incorrect value. [perl #122460]
+
+=back
+
+=head1 Acknowledgements
+
+Perl 5.21.3 represents approximately 4 weeks of development since Perl 5.21.2
+and contains approximately 21,000 lines of changes across 250 files from 25
+authors.
+
+Excluding auto-generated files, documentation and release tools, there were
+approximately 18,000 lines of changes to 160 .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.3:
+
+Aaron Crane, Abigail, Alberto Simões, Andy Dougherty, Brian Fraser, Chad
+Granum, Chris 'BinGOs' Williams, Craig A. Berry, Dagfinn Ilmari Mannsåker,
+Daniel Dragan, David Mitchell, Father Chrysostomos, H.Merijn Brand, James E
+Keenan, Jan Dubois, Jarkko Hietaniemi, Karen Etheridge, Karl Williamson, Lukas
+Mai, Peter Martini, Rafael Garcia-Suarez, syber, Tony Cook, Vladimir Marek,
+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
The format is useful for accurately presenting floating point values,
avoiding conversions to or from decimal floating point, and therefore
avoiding possible loss in precision. Notice that while most current
-platforms use the 64-bit IEEE 754 floating point, not all do.
+platforms use the 64-bit IEEE 754 floating point, not all do. Another
+potential source of (low-order) differences are the floating point
+rounding modes, which can differ between CPUs, operating systems,
+and compilers, and which Perl doesn't control.
You can also embed newlines directly in your strings, i.e., they can end
on a different line than they begin. This is nice, but if you forget
=item C<anchored(TYPE)>
If the pattern may match only at a handful of places, with C<TYPE>
-being C<BOL>, C<MBOL>, or C<GPOS>. See the table below.
+being C<SBOL>, C<MBOL>, or C<GPOS>. See the table below.
=back
END no End of program.
SUCCEED no Return from a subroutine, basically.
- # Anchors:
+ # Line Start Anchors:
+ SBOL no Match "" at beginning of line: /^/, /\A/
+ MBOL no Same, assuming multiline: /^/m
- BOL no Match "" at beginning of line.
- MBOL no Same, assuming multiline.
- SBOL no Same, assuming singleline.
- EOS no Match "" at end of string.
- EOL no Match "" at end of line.
- MEOL no Same, assuming multiline.
- SEOL no Same, assuming singleline.
+ # Line End Anchors:
+ SEOL no Match "" at end of line: /$/
+ MEOL no Same, assuming multiline: /$/m
+ EOS no Match "" at end of string: /\z/
+
+ # Match Start Anchors:
+ GPOS no Matches where last m//g left off.
+
+ # Word Boundary Opcodes:
BOUND no Match "" at any word boundary using native
charset rules for non-utf8
BOUNDL no Match "" at any locale word boundary
Unicode rules
NBOUNDA no Match "" at any word non-boundary using
ASCII rules
- GPOS no Matches where last m//g left off.
# [Special] alternatives:
-
REG_ANY no Match any one character (except newline).
SANY no Match any one character.
CANY no Match any one byte.
ANYOF sv Match character in (or not in) this class,
single char match only
+ # POSIX Character Classes:
POSIXD none Some [[:class:]] under /d; the FLAGS field
gives which one
POSIXL none Some [[:class:]] under /l; the FLAGS field
unicode rules for non-utf8, no mixing ASCII,
non-ASCII
+ # Support for long RE
+ LONGJMP off 1 1 Jump far away.
+ BRANCHJ off 1 1 BRANCH with long offset.
+
+ # Special Case Regops
IFMATCH off 1 2 Succeeds if the following matches.
UNLESSM off 1 2 Fails if the following matches.
SUSPEND off 1 1 "Independent" sub-RE.
IFTHEN off 1 1 Switch, should be preceded by switcher.
GROUPP num 1 Whether the group matched.
- # Support for long RE
-
- LONGJMP off 1 1 Jump far away.
- BRANCHJ off 1 1 BRANCH with long offset.
-
# The heavy worker
EVAL evl 1 Execute some Perl code.
=head1 NAME
-perldelta - what is new for perl v5.21.3
+perldelta - what is new for perl v5.21.4
=head1 DESCRIPTION
-This document describes differences between the 5.21.2 release and the 5.21.3
+This document describes differences between the 5.21.3 release and the 5.21.4
release.
-If you are upgrading from an earlier release such as 5.21.1, first read
-L<perl5212delta>, which describes differences between 5.21.1 and 5.21.2.
+If you are upgrading from an earlier release such as 5.21.2, first read
+L<perl5213delta>, which describes differences between 5.21.2 and 5.21.3.
=head1 Core Enhancements
-=head2 C<defined(@array = LIST)> is no longer fatal
+=head2 Infinity and NaN (not-a-number) handling improved
-In 5.21.1, C<defined(@array)> was made fatal. This has been relaxed
-to not die if the argument is assigning to an array.
+Floating point values are able to hold the special values infinity (also
+-infinity), and NaN (not-a-number). Now we more robustly recognize and
+propagate the value in computations, and on output normalize them to C<Inf> and
+C<NaN>.
-=head2 Floating point parsing has been improved
+See also the L<POSIX> enhancements.
-Parsing and printing of floating point values has been improved.
+=head1 Incompatible Changes
-As a completely new feature, hexadecimal floating point literals
-(like 0x1.23p-4) are now supported, and they can be output with
-C<printf %a>.
+=head2 Changes to the C<*> prototype
-=head1 Security
+The C<*> character in a subroutine's prototype used to allow barewords to take
+precedence over most, but not all subroutines. It was never consistent and
+exhibited buggy behaviour.
-=head2 The L<Safe> module could allow outside packages to be replaced
+Now it has been changed, so subroutines always take precedence over barewords,
+which brings it into conformity with similarly prototyped built-in functions:
-Critical bugfix: outside packages could be replaced. L<Safe> has
-been patched to 2.38 to address this.
+ sub splat($) { ... }
+ sub foo { ... }
+ splat(foo); # now always splat(foo())
+ splat(bar); # still splat('bar') as before
+ close(foo); # close(foo())
+ close(bar); # close('bar')
-=head1 Incompatible Changes
+=head1 Performance Enhancements
+
+=over 4
+
+=item *
-=head2 S<C<use UNIVERSAL '...'>> is now a fatal error
+Subroutines with an empty prototype and bodies containing just C<undef> are now
+eligible for inlining.
+L<[perl #122728]|https://rt.perl.org/Ticket/Display.html?id=122728>
-Importing functions from C<UNIVERSAL> has been deprecated since v5.12, and
-is now a fatal error. S<C<"use UNIVERSAL">> without any arguments is still
-allowed.
+=item *
+
+Subroutines in packages no longer need to carry typeglobs around with them.
+Declaring a subroutine will now put a simple sub reference in the stash if
+possible, saving memory. The typeglobs still notionally exist, so accessing
+them will cause the subroutine reference to be upgraded to a typeglob. This
+optimization does not currently apply to XSUBs or exported subroutines, and
+method calls will undo it, since they cache things in typeglobs.
+L<[perl #120441]|https://rt.perl.org/Ticket/Display.html?id=120441>
+
+=back
=head1 Modules and Pragmata
+=head2 New Modules and Pragmata
+
+=over 4
+
+=item *
+
+L<B::Op_private> provides detailed information about the flags used in the
+C<op_private> field of perl opcodes.
+
+=back
+
=head2 Updated Modules and Pragmata
=over 4
=item *
-L<B::Debug> has been upgraded from version 1.19 to 1.21.
+L<Archive::Tar> has been upgraded from version 2.00 to 2.02.
+
+Tests can now be run in parallel.
+
+=item *
+
+L<Attribute::Handlers> has been upgraded from version 0.96 to 0.97.
+
+Internal changes to account for the fact that subroutines in packages no longer
+need to carry typeglobs around with them (see under L</Performance
+Enhancements>).
=item *
-L<Config::Perl::V> has been upgraded from version 0.20 to 0.22.
+L<attributes> has been upgraded from version 0.22 to 0.23.
+
+The usage of C<memEQs> in the XS has been corrected.
+L<[perl #122701]|https://rt.perl.org/Ticket/Display.html?id=122701>
=item *
-L<CPAN::Meta> has been upgraded from version 2.141520 to 2.142060.
+L<B> has been upgraded from version 1.50 to 1.51.
+
+It provides a new C<B::safename> function, based on the existing
+C<< B::GV->SAFENAME >>, that converts "\cOPEN" to "^OPEN".
=item *
-L<CPAN::Meta::Requirements> has been upgraded from version 2.125 to 2.126.
+L<B::Concise> has been upgraded from version 0.992 to 0.993.
+
+Internal changes to account for the fact that the defines and labels for the
+flags in the C<op_private> field of OPs are now auto-generated (see under
+L</Internal Changes>).
=item *
-L<ExtUtils::CBuilder> was moved from F<dist> to F<cpan>.
+L<B::Deparse> has been upgraded from version 1.27 to 1.28.
+
+It now deparses C<our(I<LIST>)> and typed lexical (C<my Dog $spot>) correctly.
=item *
-L<ExtUtils::CBuilder> has been upgraded from version 0.280216 to 0.280217.
+L<bignum> has been upgraded from version 0.37 to 0.38.
+
+An C<eval BLOCK> rather than an C<eval EXPR> is now used to see if we can find
+Math::BigInt::Lite.
=item *
-L<ExtUtils::Install> was moved from F<dist> to F<cpan>.
+L<constant> has been upgraded from version 1.31 to 1.32.
+
+It now accepts fully-qualified constant names, allowing constants to be defined
+in packages other than the caller.
=item *
-L<ExtUtils::Manifest> has been upgraded from version 1.64 to 1.65.
-It was also moved from F<dist> to F<cpan>.
+L<CPAN::Meta::Requirements> has been upgraded from version 2.126 to 2.128.
+
+Works around limitations in version::vpp detecting v-string magic and adds
+support for forthcoming L<ExtUtils::MakeMaker> bootstrap F<version.pm> for
+Perls older than 5.10.0.
=item *
-L<HTTP::Tiny> has been upgraded from version 0.043 to 0.047.
+L<Data::Dumper> has been upgraded from version 2.152 to 2.154.
+
+Fixes CVE-2014-4330 by adding a configuration variable/option to limit
+recursion when dumping deep data structures.
=item *
-L<IPC::Open3> has been upgraded from version 1.17 to 1.18.
+L<experimental> has been upgraded from version 0.008 to 0.010.
+
+Hardcodes features for Perls older than 5.15.7.
=item *
-L<Module::CoreList> has been upgraded from version 5.021002 to 5.021003.
+L<ExtUtils::CBuilder> has been upgraded from version 0.280217 to 0.280219.
+
+Fixes a regression on Android.
+L<[perl #122675]|https://rt.perl.org/Ticket/Display.html?id=122675>
=item *
-L<Opcode> has been upgraded from version 1.27 to 1.28.
+L<ExtUtils::Install> has been upgraded from version 1.68 to 2.04.
+
+No changes to installed files other than version bumps.
=item *
-L<perl5db.pl> has been upgraded from version 1.45 to 1.46.
+L<ExtUtils::Manifest> has been upgraded from version 1.65 to 1.68.
+
+Fixes a bug with C<maniread()>'s handling of quoted filenames and improves
+C<manifind()> to follow symlinks.
+L<[perl #122415]|https://rt.perl.org/Ticket/Display.html?id=122415>
=item *
-L<perlfaq> has been upgraded from version 5.0150044 to 5.0150045.
+L<File::Find> has been upgraded from version 1.27 to 1.28.
+
+C<find()> and C<finddepth()> will now warn if passed inappropriate or
+misspelled options.
=item *
-L<POSIX> has been upgraded from version 1.41 to 1.42.
+L<Getopt::Std> has been upgraded from version 1.10 to 1.11.
+
+Corrects a typo in the documentation.
=item *
-L<Safe> has been upgraded from version 2.37 to 2.38.
+L<HTTP::Tiny> has been upgraded from version 0.047 to 0.049.
+
+C<keep_alive> is now fork-safe and thread-safe.
=item *
-L<Socket> has been upgraded from version 2.014 to 2.015.
+L<IO> has been upgraded from version 1.33 to 1.34.
+
+The XS implementation has been fixed for the sake of older Perls.
=item *
-L<Sys::Hostname> has been upgraded from version 1.18 to 1.19
+L<IO::Socket::IP> has been upgraded from version 0.31 to 0.32.
+
+Implements Timeout for C<connect()>.
+L<[cpan #92075]|https://rt.cpan.org/Ticket/Display.html?id=92075>
=item *
-L<UNIVERSAL> has been upgraded from version 1.11 to 1.12.
+L<Locale::Codes> has been upgraded from version 3.31 to 3.32.
-=back
+New codes have been added.
-=head1 Documentation
+=item *
-=head2 Changes to Existing Documentation
+L<Math::BigInt> has been upgraded from version 1.9996 to 1.9997.
-=head3 L<perlexperiment>
+The documentation now gives test examples using L<Test::More> rather than
+L<Test>.
-=over 4
+=item *
+
+L<Module::CoreList> has been upgraded from version 5.021003 to 5.20140920.
+
+Updated to cover the latest releases of Perl.
=item *
-Added reference to L<feature>.
+L<overload> has been upgraded from version 1.22 to 1.23.
+
+A redundant C<ref $sub> check has been removed.
+
+=item *
+
+PathTools has been upgraded from version 3.49 to 3.50.
+
+A warning from the B<gcc> compiler is now avoided when building the XS.
+
+=item *
+
+L<Pod::Perldoc> has been upgraded from version 3.23 to 3.24.
+
+Filehandles opened for reading or writing now have C<:encoding(UTF-8)> set.
+L<[cpan #98019]|https://rt.cpan.org/Ticket/Display.html?id=98019>
+
+=item *
+
+L<POSIX> has been upgraded from version 1.42 to 1.43.
+
+The C99 math functions and constants (for example acosh, isinf, isnan, round,
+trunc; M_E, M_SQRT2, M_PI) have been added.
+
+=item *
+
+Scalar-List-Utils has been upgraded from version 1.39 to 1.41.
+
+A new module, L<Sub::Util>, has been added, containing functions related to
+CODE refs, including C<subname> (inspired by Sub::Identity) and C<set_subname>
+(copied and renamed from Sub::Name).
+
+The use of C<GetMagic> in C<List::Util::reduce()> has also been fixed.
+L<[cpan #63211]|https://rt.cpan.org/Ticket/Display.html?id=63211>
+
+=item *
+
+L<Term::ReadLine> has been upgraded from version 1.14 to 1.15.
+
+Faster checks are now made first in some if-statements.
+
+=item *
+
+L<Test::Harness> has been upgraded from version 3.32 to 3.33.
+
+Various documentation fixes.
+
+=item *
+
+L<Test::Simple> has been upgraded from version 1.001003 to 1.001006.
+
+Various documentation fixes.
+
+=item *
+
+L<threads> has been upgraded from version 1.95 to 1.96.
+
+No changes to installed files other than version bumps.
+
+=item *
+
+L<Time::Piece> has been upgraded from version 1.27 to 1.29.
+
+When pretty printing negative Time::Seconds, the "minus" is no longer lost.
+
+=item *
+
+L<version> has been upgraded from version 0.9908 to 0.9909.
+
+Numerous changes. See the F<Changes> file in the CPAN distribution for
+details.
=back
-=head3 L<perlguts>
+=head1 Documentation
+
+=head2 Changes to Existing Documentation
+
+=head3 L<perlfunc>
=over 4
=item *
-Details on C level symbols and libperl.t added.
+Calling C<delete> or C<exists> on array values is now described as "strongly
+discouraged" rather than "deprecated".
=back
-=head3 L<perlhacktips>
+=head3 L<perlpolicy>
=over 4
=item *
-Recommended replacements for tmpfile, atoi, strtol, and strtoul added.
+The conditions for marking an experimental feature as non-experimental are now
+set out.
=back
-=head3 L<perlop>
+=head3 L<perlrecharclass>
=over 4
=item *
-ASCII v. EBCDIC clarifications added.
+The documentation of Bracketed Character Classes has been expanded to cover the
+improvements in C<qr/[\N{named sequence}]/> (see under L</Selected Bug Fixes>).
=back
-=head3 L<perlsec>
+=head3 L<perlsyn>
=over 4
=item *
-Comments added on algorithmic complexity and tied hashes.
+An ambiguity in the documentation of the Ellipsis statement has been corrected.
+L<[perl #122661]|https://rt.perl.org/Ticket/Display.html?id=122661>
=back
-=head3 L<perlvms>
+=head3 L<perlxs>
=over 4
=item *
-Updated documentation on environment and shell interaction in VMS.
+Added a discussion of locale issues in XS code.
=back
=head2 New Diagnostics
-=head3 New Errors
+=head3 New Warnings
=over 4
=item *
-L<Hexadecimal float: internal error|perldiag/"Hexadecimal float: internal error">
+L<Character in 'C' format overflow in pack|perldiag/"Character in 'C' format overflow in pack">
-(F) Something went horribly bad in hexadecimal float handling.
+(W pack) You tried converting an infinity or not-a-number to an unsigned
+character, which makes no sense. Perl behaved as if you tried to pack 0xFF.
=item *
-L<Hexadecimal float: unsupported long double format|perldiag/"Hexadecimal float: unsupported long double format">
+L<Character in 'c' format overflow in pack|perldiag/"Character in 'c' format overflow in pack">
-(F) You have configured Perl to use long doubles but
-the internals of the long double format are unknown,
-therefore the hexadecimal float output is impossible.
+(W pack) You tried converting an infinity or not-a-number to a signed
+character, which makes no sense. Perl behaved as if you tried to pack 0xFF.
+
+=item *
+
+L<Invalid number (%f) in chr|perldiag/"Invalid number (%f) in chr">
+
+(W utf8) You passed an invalid number (like an infinity or not-a-number) to
+C<chr>. Those are not valid character numbers, so it returned the Unicode
+replacement character (U+FFFD).
=back
-=head3 New Warnings
+=head2 Changes to Existing Diagnostics
=over 4
=item *
-L<Hexadecimal float: exponent overflow|perldiag/"Hexadecimal float: exponent overflow">
+L<Global symbol "%s" requires explicit package name|perldiag/"Global symbol "%s" requires explicit package name (did you forget to declare "my %s"?)">
-(W overflow) The hexadecimal floating point has larger exponent
-than the floating point supports.
+This message has had '(did you forget to declare "my %s"?)' appended to it, to
+make it more helpful to new Perl programmers.
+L<[perl #121638]|https://rt.perl.org/Ticket/Display.html?id=121638>
=item *
-L<Hexadecimal float: exponent underflow|perldiag/"Hexadecimal float: exponent underflow">
+L<\N{} in character class restricted to one character in regex; marked by S<<-- HERE> in mE<sol>%sE<sol>|perldiag/"\N{} in inverted character class or as a range end-point is restricted to one character in regex; marked by S<<-- HERE> in m/%s/">
+
+This message has had 'character class' changed to 'inverted character class or
+as a range end-point is' to reflect improvements in C<qr/[\N{named sequence}]/>
+(see under L</Selected Bug Fixes>).
+
+=item *
+
+L<panic: frexp|perldiag/"panic: frexp: %f">
+
+This message has had ': %f' appended to it, to show what the offending floating
+point number is.
+
+=back
+
+=head2 Diagnostic Removals
-(W overflow) The hexadecimal floating point has smaller exponent
-than the floating point supports.
+=over 4
=item *
-L<Hexadecimal float: mantissa overflow|perldiag/"Hexadecimal float: mantissa overflow">
+"Constant is not a FOO reference"
-(W overflow) The hexadecimal floating point literal had more bits in
-the mantissa (the part between the 0x and the exponent, also known as
-the fraction or the significand) than the floating point supports.
+Compile-time checking of constant dereferencing (e.g., C<< my_constant->() >>)
+has been removed, since it was not taking overloading into account.
+L<[perl #69456]|https://rt.perl.org/Ticket/Display.html?id=69456>
+L<[perl #122607]|https://rt.perl.org/Ticket/Display.html?id=122607>
=item *
-L<Hexadecimal float: precision loss|perldiag/"Hexadecimal float: precision loss">
+"Ambiguous use of -foo resolved as -&foo()"
-(W overflow) The hexadecimal floating point had internally more
-digits than could be output. This can be caused by unsupported
-long double formats, or by 64-bit integers not being available
-(needed to retrieve the digits under some configurations).
+There is actually no ambiguity here, and this impedes the use of negated
+constants; e.g., C<-Inf>.
=back
-=head2 Changes to Existing Diagnostics
+=head1 Configuration and Compilation
=over 4
=item *
-C<require> with no argument or undef used to warn about a Null filename; now
-it dies with C<Missing or undefined argument to require>.
+For long doubles (to get more precision and range for floating point numbers)
+one can now use the GCC quadmath library which implements the quadruple
+precision floating point numbers in x86 and ia64 platforms. See F<INSTALL> for
+details.
=back
-=head1 Configuration and Compilation
+=head1 Testing
=over 4
=item *
-MurmurHash64A and MurmurHash64B can now be configured as the internal hash
-function.
+A new test script, F<op/infnan.t>, has been added to test if Inf and NaN are
+working correctly. See L</Infinity and NaN (not-a-number) handling improved>.
-=back
+=item *
+
+A new test script, F<re/rt122747.t>, has been added to test that the fix for
+L<perl #122747|https://rt.perl.org/Ticket/Display.html?id=122747> is working.
-=head1 Platform Support
+=back
-=head2 Platform-Specific Notes
+=head1 Internal Changes
=over 4
-=item Android
+=item *
+
+C<save_re_context> no longer does anything and has been moved to F<mathoms.c>.
+
+=item *
+
+C<cv_name> is a new API function that can be passed a CV or GV. It returns an
+SV containing the name of the subroutine for use in diagnostics.
+L<[perl #116735]|https://rt.perl.org/Ticket/Display.html?id=116735>
+L<[perl #120441]|https://rt.perl.org/Ticket/Display.html?id=120441>
+
+=item *
-Build support has been improved for cross-compiling in general and for
-Android in particular.
+C<cv_set_call_checker_flags> is a new API function that works like
+C<cv_set_call_checker>, except that it allows the caller to specify whether the
+call checker requires a full GV for reporting the subroutine's name, or whether
+it could be passed a CV instead. Whatever value is passed will be acceptable
+to C<cv_name>. C<cv_set_call_checker> guarantees there will be a GV, but it
+may have to create one on the fly, which is inefficient.
+L<[perl #116735]|https://rt.perl.org/Ticket/Display.html?id=116735>
-=item Solaris
+=item *
-C<c99> options have been cleaned up, hints look for C<solstudio>
-as well as C<SUNWspro>, and support for native C<setenv> has been added.
+C<CvGV> (which is not part of the API) is now a more complex macro, which may
+call a function and reify a GV. For those cases where is has been used as a
+boolean, C<CvHASGV> has been added, which will return true for CVs that
+notionally have GVs, but without reifying the GV. C<CvGV> also returns a GV
+now for lexical subs.
+L<[perl #120441]|https://rt.perl.org/Ticket/Display.html?id=120441>
-=item VMS
+=item *
-C<finite>, C<finitel>, and C<isfinite> detection has been added to
-C<configure.com>, environment handling has had some minor changes, and
-a fix for legacy feature checking status.
+Added L<perlapi/sync_locale>. Changing the program's locale should be avoided
+by XS code. Nevertheless, certain non-Perl libraries called from XS, such as
+C<Gtk> do so. When this happens, Perl needs to be told that the locale has
+changed. Use this function to do so, before returning to Perl.
-=item Windows
+=item *
-C<%I64d> is now being used instead of C<%lld> for MinGW.
+The defines and labels for the flags in the C<op_private> field of OPs are now
+auto-generated from data in F<regen/op_private>. The noticeable effect of this
+is that some of the flag output of C<Concise> might differ slightly, and the
+flag output of C<perl -Dx> may differ considerably (they both use the same set
+of labels now). Also in debugging builds, there is a new assert in
+C<op_free()> that checks that the op doesn't have any unrecognized flags set in
+C<op_private>.
=back
-=head1 Internal Changes
+=head1 Selected Bug Fixes
=over 4
=item *
-Added L<perlapi/sync_locale>.
-Changing the program's locale should be avoided by XS code. Nevertheless,
-certain non-Perl libraries called from XS, such as C<Gtk> do so. When this
-happens, Perl needs to be told that the locale has changed. Use this function
-to do so, before returning to Perl.
+Constant dereferencing now works correctly for typeglob constants. Previously
+the glob was stringified and its name looked up. Now the glob itself is used.
+L<[perl #69456]|https://rt.perl.org/Ticket/Display.html?id=69456>
=item *
-Added L<perlapi/grok_atou> as a safer replacement for atoi and strtol.
+When parsing a funny character ($ @ % &) followed by braces, the parser no
+longer tries to guess whether it is a block or a hash constructor (causing a
+syntax error when it guesses the latter), since it can only be a block.
-=back
+=item *
-=head1 Selected Bug Fixes
+C<undef $reference> now frees the referent immediately, instead of hanging on
+to it until the next statement.
+L<[perl #122556]|https://rt.perl.org/Ticket/Display.html?id=122556>
-=over 4
+=item *
+
+Various cases where the name of a sub is used (autoload, overloading, error
+messages) used to crash for lexical subs, but have been fixed.
+
+=item *
+
+Bareword lookup now tries to avoid vivifying packages if it turns out the
+bareword is not going to be a subroutine name.
+
+=item *
+
+Compilation of anonymous constants (e.g., C<sub () { 3 }>) no longer deletes
+any subroutine named C<__ANON__> in the current package. Not only was
+C<*__ANON__{CODE}> cleared, but there was a memory leak, too. This bug goes
+back to Perl 5.8.0.
+
+=item *
+
+Stub declarations like C<sub f;> and C<sub f ();> no longer wipe out constants
+of the same name declared by C<use constant>. This bug was introduced in Perl
+5.10.0.
+
+=item *
+
+Under some conditions a warning raised in compilation of regular expression
+patterns could be displayed multiple times. This is now fixed.
+
+=item *
+
+C<qr/[\N{named sequence}]/> now works properly in many instances. Some names
+known to C<\N{...}> refer to a sequence of multiple characters, instead of the
+usual single character. Bracketed character classes generally only match
+single characters, but now special handling has been added so that they can
+match named sequences, but not if the class is inverted or the sequence is
+specified as the beginning or end of a range. In these cases, the only
+behavior change from before is a slight rewording of the fatal error message
+given when this class is part of a C<?[...])> construct. When the C<[...]>
+stands alone, the same non-fatal warning as before is raised, and only the
+first character in the sequence is used, again just as before.
+
+=item *
+
+Tainted constants evaluated at compile time no longer cause unrelated
+statements to become tainted.
+L<[perl #122669]|https://rt.perl.org/Ticket/Display.html?id=122669>
+
+=item *
+
+C<open $$fh, ...>, which vivifies a handle with a name like "main::_GEN_0", was
+not giving the handle the right reference count, so a double free could happen.
+
+=item *
+
+When deciding that a bareword was a method name, the parser would get confused
+if an "our" sub with the same name existed, and look up the method in the
+package of the "our" sub, instead of the package of the invocant.
+
+=item *
+
+The parser no longer gets confused by C<\U=> within a double-quoted string. It
+used to produce a syntax error, but now compiles it correctly.
+L<[perl #80368]|https://rt.perl.org/Ticket/Display.html?id=80368>
+
+=item *
+
+It has always been the intention for the C<-B> and C<-T> file test operators to
+treat UTF-8 encoded files as text. (L<perlfunc|perlfunc/-X FILEHANDLE> has
+been updated to say this.) Previously, it was possible for some files to be
+considered UTF-8 that actually weren't valid UTF-8. This is now fixed. The
+operators now work on EBCDIC platforms as well.
+
+=item *
+
+Under some conditions warning messages raised during regular expression pattern
+compilation were being output more than once. This has now been fixed.
+
+=item *
+
+A regression has been fixed that was introduced in Perl 5.20.0 (fixed in Perl
+5.20.1 as well as here) in which a UTF-8 encoded regular expression pattern
+that contains a single ASCII lowercase letter does not match its uppercase
+counterpart.
+L<[perl #122655]|https://rt.perl.org/Ticket/Display.html?id=122655>
+
+=item *
+
+Constant folding could incorrectly suppress warnings if lexical warnings (C<use
+warnings> or C<no warnings>) were not in effect and C<$^W> were false at
+compile time and true at run time.
+
+=item *
+
+Loading UTF8 tables during a regular expression match could cause assertion
+failures under debugging builds if the previous match used the very same
+regular expression.
+L<[perl #122747]|https://rt.perl.org/Ticket/Display.html?id=122747>
+
+=item *
+
+Thread cloning used to work incorrectly for lexical subs, possibly causing
+crashes or double frees on exit.
+
+=item *
+
+Since Perl 5.14.0, deleting C<$SomePackage::{__ANON__}> and then undefining an
+anonymous subroutine could corrupt things internally, resulting in
+L<Devel::Peek> crashing or L<B.pm|B> giving nonsensical data. This has been
+fixed.
+
+=item *
+
+C<(caller $n)[3]> now reports names of lexical subs, instead of treating them
+as "(unknown)".
+
+=item *
+
+C<sort subname LIST> now supports lexical subs for the comparison routine.
=item *
-Failing to compile C<use Foo> in an eval could leave a spurious
-C<BEGIN> subroutine definition, which would produce a "Subroutine
-BEGIN redefined" warning on the next use of C<use>, or other C<BEGIN>
-block. [perl #122107]
+Aliasing (e.g., via C<*x = *y>) could confuse list assignments that mention the
+two names for the same variable on either side, causing wrong values to be
+assigned.
+L<[perl #15667]|https://rt.perl.org/Ticket/Display.html?id=15667>
=item *
-C<method { BLOCK } ARGS> syntax now correctly parses the arguments if they
-begin with an opening brace. [perl #46947]
+Long here-doc terminators could cause a bad read on short lines of input. This
+has been fixed. It is doubtful that any crash could have occurred. This bug
+goes back to when here-docs were introduced in Perl 3.000 twenty-five years
+ago.
=item *
-External libraries and Perl may have different ideas of what the locale is.
-This is problematic when parsing version strings if the locale's numeric
-separator has been changed. Version parsing has been patched to ensure
-it handles the locales correctly. [perl #121930]
+An optimization in C<split> to treat C<split/^/> like C<split/^/m> had the
+unfortunate side-effect of also treating C<split/\A/> like C<split/^/m>, which
+it should not. This has been fixed. (Note, however, that C<split/^x/> does
+not behave like C<split/^x/m>, which is also considered to be a bug and will be
+fixed in a future version.)
+L<[perl #122761]|https://rt.perl.org/Ticket/Display.html?id=122761>
=item *
-A bug has been fixed where zero-length assertions and code blocks inside of a
-regex could cause C<pos> to see an incorrect value. [perl #122460]
+The little-known C<my Class $var> syntax (see L<fields> and L<attributes>)
+could get confused in the scope of C<use utf8> if C<Class> were a constant
+whose value contained Latin-1 characters.
=back
=head1 Acknowledgements
-Perl 5.21.3 represents approximately 4 weeks of development since Perl 5.21.2
-and contains approximately 21,000 lines of changes across 250 files from 25
+Perl 5.21.4 represents approximately 4 weeks of development since Perl 5.21.3
+and contains approximately 29,000 lines of changes across 520 files from 30
authors.
Excluding auto-generated files, documentation and release tools, there were
-approximately 18,000 lines of changes to 160 .pm, .t, .c and .h files.
+approximately 15,000 lines of changes to 390 .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.3:
+of users and developers. The following people are known to have contributed
+the improvements that became Perl 5.21.4:
-Aaron Crane, Abigail, Alberto Simões, Andy Dougherty, Brian Fraser, Chad
-Granum, Chris 'BinGOs' Williams, Craig A. Berry, Dagfinn Ilmari Mannsåker,
-Daniel Dragan, David Mitchell, Father Chrysostomos, H.Merijn Brand, James E
-Keenan, Jan Dubois, Jarkko Hietaniemi, Karen Etheridge, Karl Williamson, Lukas
-Mai, Peter Martini, Rafael Garcia-Suarez, syber, Tony Cook, Vladimir Marek,
-Yves Orton.
+Alberto Simões, Alexandre (Midnite) Jousset, Andy Dougherty, Anthony Heading,
+Brian Fraser, Chris 'BinGOs' Williams, Craig A. Berry, Daniel Dragan, David
+Mitchell, Doug Bell, Father Chrysostomos, George Greer, H.Merijn Brand, James E
+Keenan, Jarkko Hietaniemi, Jerry D. Hedden, Karen Etheridge, Karl Williamson,
+Olivier Mengué, Peter Martini, Reini Urban, Ricardo Signes, Steffen Müller,
+Steve Hay, Sullivan Beck, syber, Tadeusz Sośnierz, 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
+from version control history. In particular, it does not include the names of
the (very much appreciated) contributors who reported issues to the Perl bug
tracker.
Many of the changes included in this version originated in the CPAN modules
-included in Perl's core. We're grateful to the entire CPAN community for
+included in Perl's core. We're grateful to the entire CPAN community for
helping Perl to flourish.
For a more complete list of all of Perl's historical contributors, please see
functioning as a class, but that package doesn't define that particular
method, nor does any of its base classes. See L<perlobj>.
+=item Can't locate object method "%s" via package "%s" (perhaps you forgot
+to load "%s"?)
+
+(F) You called a method on a class that did not exist, and the method
+could not be found in UNIVERSAL. This often means that a method
+requires a package that has not been loaded.
+
=item Can't locate package %s for @%s::ISA
(W syntax) The @ISA array contained the name of another package that
discouraged, and will generate the warning (when enabled)
L</""\c%c" is more clearly written simply as "%s"">.
+=item Character in 'C' format overflow in pack
+
+(W pack) You tried converting an infinity or not-a-number to an
+unsigned character, which makes no sense. Perl behaved as if you
+tried to pack 0xFF.
+
+=item Character in 'c' format overflow in pack
+
+(W pack) You tried converting an infinity or not-a-number to a
+signed character, which makes no sense. Perl behaved as if you
+tried to pack 0xFF.
+
=item Character in 'C' format wrapped in pack
(W pack) You said
=item "\c%c" is more clearly written simply as "%s"
(W syntax) The C<\cI<X>> construct is intended to be a way to specify
-non-printable characters. You used it for a printable one, which is better
-written as simply itself, perhaps preceded by a backslash for non-word
-characters.
+non-printable characters. You used it for a printable one, which
+is better written as simply itself, perhaps preceded by a backslash
+for non-word characters. Doing it the way you did is not portable
+between ASCII and EBCDIC platforms.
=item Cloning substitution context is unimplemented
in any future release of perl. See the explanation under
L<perlsyn/Experimental Details on given and when>.
-=item Global symbol "%s" requires explicit package name
+=item Global symbol "%s" requires explicit package name (did you forget to
+declare "my %s"?)
(F) You've said "use strict" or "use strict vars", which indicates
that all variables must either be lexically scoped (using "my" or "state"),
=item Hexadecimal float: exponent overflow
-(W overflow) The hexadecimal floating point has larger exponent
+(W overflow) The hexadecimal floating point has a larger exponent
than the floating point supports.
=item Hexadecimal float: exponent underflow
-(W overflow) The hexadecimal floating point has smaller exponent
+(W overflow) The hexadecimal floating point has a smaller exponent
than the floating point supports.
=item Hexadecimal float: internal error
=item Hexadecimal float: unsupported long double format
(F) You have configured Perl to use long doubles but
-the internals of the long double format are unknown,
+the internals of the long double format are unknown;
therefore the hexadecimal float output is impossible.
=item Hexadecimal number > 0xffffffff non-portable
=item Ignoring zero length \N{} in character class in regex; marked by
S<<-- HERE> in m/%s/
-(W regexp) Named Unicode character escapes C<(\N{...})> may return a
+(W regexp) Named Unicode character escapes (C<\N{...}>) may return a
zero-length sequence. When such an escape is used in a character class
its behaviour is not well defined. Check that the correct escape has
been used, and the correct charname handler is in scope.
=item Invalid negative number (%s) in chr
(W utf8) You passed a negative number to C<chr>. Negative numbers are
-not valid characters numbers, so it return the Unicode replacement
+not valid character numbers, so it returns the Unicode replacement
character (U+FFFD).
+=item Invalid number (%f) in chr
+
+(W utf8) You passed an invalid number (like an infinity or
+not-a-number) to C<chr>. Those are not valid character numbers,
+so it return the Unicode replacement character (U+FFFD).
+
=item invalid option -D%c, use -D'' to see choices
(S debugging) Perl was called with invalid debugger flags. Call perl
class loses its specialness: it matches almost everything, which is
probably not what you want.
-=item \N{} in character class restricted to one character in regex; marked
+=item \N{} in inverted character class or as a range end-point is restricted to one character in regex; marked
by S<<-- HERE> in m/%s/
-(F) Named Unicode character escapes C<(\N{...})> may return a
-multi-character sequence. Such an escape may not be used in
-a character class, because character classes always match one
-character of input. Check that the correct escape has been used,
-and the correct charname handler is in scope. The S<<-- HERE> shows
-whereabouts in the regular expression the problem was discovered.
+(F) Named Unicode character escapes (C<\N{...}>) may return a
+multi-character sequence. Even though a character class is
+supposed to match just one character of input, perl will match the
+whole thing correctly, except when the class is inverted (C<[^...]>),
+or the escape is the beginning or final end point of a range. The
+mathematically logical behavior for what matches when inverting
+is very different from what people expect, so we have decided to
+forbid it. Similarly unclear is what should be generated when the
+C<\N{...}> is used as one of the end points of the range, such as in
+
+ [\x{41}-\N{ARABIC SEQUENCE YEH WITH HAMZA ABOVE WITH AE}]
+
+What is meant here is unclear, as the C<\N{...}> escape is a sequence
+of code points, so this is made an error.
=item \N{NAME} must be resolved by the lexer in regex; marked by
S<<-- HERE> in m/%s/
(P) While attempting folding constants an exception other than an C<eval>
failure was caught.
-=item panic: frexp
+=item panic: frexp: %f
(P) The library function frexp() failed, making printf("%f") impossible.
command-line switch. (This output goes to STDOUT unless you've
redirected it with select().)
-=item (perhaps you forgot to load "%s"?)
-
-(F) This is an educated guess made in conjunction with the message
-"Can't locate object method \"%s\" via package \"%s\"". It often means
-that a method requires a package that has not been loaded.
-
=item Perl folding rules are not up-to-date for 0x%X; please use the perlbug
utility to report; in regex; marked by S<<-- HERE> in m/%s/
=item Using just the first character returned by \N{} in character class in
regex; marked by S<<-- HERE> in m/%s/
-(W regexp) A charnames handler may return a sequence of more than one
-character. Currently all but the first one are discarded when used in
-a regular expression pattern bracketed character class.
+(W regexp) Named Unicode character escapes C<(\N{...})> may return
+a multi-character sequence. Even though a character class is
+supposed to match just one character of input, perl will match
+the whole thing correctly, except when the class is inverted
+(C<[^...]>), or the escape is the beginning or final end point of
+a range. For these, what should happen isn't clear at all. In
+these circumstances, Perl discards all but the first character
+of the returned sequence, which is not likely what you want.
=item Using !~ with %s doesn't make sense
=item Zero length \N{} in regex; marked by S<<-- HERE> in m/%s/
-(F) Named Unicode character escapes C<(\N{...})> may return a zero-length
+(F) Named Unicode character escapes (C<\N{...}>) may return a zero-length
sequence. Such an escape was used in an extended character class, i.e.
C<(?[...])>, which is not permitted. Check that the correct escape has
been used, and the correct charnames handler is in scope. The S<<-- HERE>
after their pseudo-children have exited.
Starting with Perl 5.14 a parent will not wait() automatically
-for any child that has been signalled with C<sig('TERM', ...)>
+for any child that has been signalled with C<kill('TERM', ...)>
to avoid a deadlock in case the child is blocking on I/O and
never receives the signal.
-g File has setgid bit set.
-k File has sticky bit set.
- -T File is an ASCII text file (heuristic guess).
+ -T File is an ASCII or UTF-8 text file (heuristic guess).
-B File is a "binary" file (opposite of -T).
-M Script start time minus file modification time, in days.
in effect. Read the documentation for the C<filetest> pragma for more
information.
-The C<-T> and C<-B> switches work as follows. The first block or so of the
-file is examined for odd characters such as strange control codes or
-characters with the high bit set. If too many strange characters (>30%)
-are found, it's a C<-B> file; otherwise it's a C<-T> file. Also, any file
-containing a zero byte in the first block is considered a binary file. If C<-T>
-or C<-B> is used on a filehandle, the current IO buffer is examined
+The C<-T> and C<-B> switches work as follows. The first block or so of
+the file is examined to see if it is valid UTF-8 that includes non-ASCII
+characters. If, so it's a C<-T> file. Otherwise, that same portion of
+the file is examined for odd characters such as strange control codes or
+characters with the high bit set. If more than a third of the
+characters are strange, it's a C<-B> file; otherwise it's a C<-T> file.
+Also, any file containing a zero byte in the examined portion is
+considered a binary file. (If executed within the scope of a L<S<use
+locale>|perllocale> which includes C<LC_CTYPE>, odd characters are
+anything that isn't a printable nor space in the current locale.) If
+C<-T> or C<-B> is used on a filehandle, the current IO buffer is
+examined
rather than the first block. Both C<-T> and C<-B> return true on an empty
file, or a file at EOF when testing a filehandle. Because you have to
read a file to do the C<-T> test, on most occasions you want to use a C<-f>
context, returns the caller's package name if there I<is> a caller (that is, if
we're in a subroutine or C<eval> or C<require>) and the undefined value
otherwise. caller never returns XS subs and they are skipped. The next pure
-perl sub will appear instead of the XS sub in caller's return values. In list
+perl sub will appear instead of the XS
+sub in caller's return values. In list
context, caller returns
# 0 1 2
= caller($i);
Here, $subroutine is the function that the caller called (rather than the
-function containing the caller). Note that $subroutine may be C<(eval)> if
+function containing the caller). Note that $subroutine may be C<(eval)> if
the frame is not a subroutine call, but an C<eval>. In such a case
additional elements $evaltext and
C<$is_require> are set: C<$is_require> is true if the frame is created by a
deleting array elements never changes indices of existing values; use shift()
or splice() for that. However, if any deleted elements fall at the end of an
array, the array's size shrinks to the position of the highest element that
-still tests true for exists(), or to 0 if none do. In other words, an
+still tests true for exists(), or to 0 if none do. In other words, an
array won't have trailing nonexistent elements after a delete.
-B<WARNING:> Calling delete on array values is deprecated and likely to
-be removed in a future version of Perl.
+B<WARNING:> Calling C<delete> on array values is strongly discouraged. The
+notion of deleting or checking the existence of Perl array elements is not
+conceptually coherent, and can lead to surprising behavior.
Deleting from C<%ENV> modifies the environment. Deleting from a hash tied to
a DBM file deletes the entry from the DBM file. Deleting from a C<tied> hash
print "True\n" if $hash{$key};
exists may also be called on array elements, but its behavior is much less
-obvious and is strongly tied to the use of L</delete> on arrays. B<Be aware>
-that calling exists on array values is deprecated and likely to be removed in
-a future version of Perl.
+obvious and is strongly tied to the use of L</delete> on arrays.
+
+B<WARNING:> Calling C<exists> on array values is strongly discouraged. The
+notion of deleting or checking the existence of Perl array elements is not
+conceptually coherent, and can lead to surprising behavior.
print "Exists\n" if exists $array[$index];
print "Defined\n" if defined $array[$index];
D A float of long-double precision in native format.
(Long doubles are available only if your system supports
long double values _and_ if Perl has been compiled to
- support those. Raises an exception otherwise.)
+ support those. Raises an exception otherwise.
+ Note that there are different long double formats.)
p A pointer to a null-terminated string.
P A pointer to a structure (fixed-length string).
=item else
-=item elseif
-
=item elsif
=item for
These flow-control keywords are documented in L<perlsyn/"Compound Statements">.
+=item elseif
+
+The "else if" keyword is spelled C<elsif> in Perl. There's no C<elif>
+or C<else if> either. It does parse C<elseif>, but only to warn you
+about not using it.
+
+See the documentation for flow-control keywords in L<perlsyn/"Compound
+Statements">.
+
=back
=over
After you've generated your patch you should sent it
to perlbug@perl.org (as discussed L<in the previous
-section|/"Patch workflow"> with a normal mail client as an
+section|/"Patch workflow">) with a normal mail client as an
attachment, along with a description of the patch.
You B<must not> use git-send-email(1) to send patches generated with
The IVdf will expand to whatever is the correct format for the IVs.
+Note that there are different "long doubles": Perl will use
+whatever the compiler has.
+
If you are printing addresses of pointers, use UVxf combined
with PTR2UV(), do not use %lx or %p.
Matt S Trout, David Golden, Florian Ragwitz, Tatsuhiko Miyagawa,
Chris C<BinGOs> Williams, Zefram, Ævar Arnfjörð Bjarmason, Stevan
Little, Dave Rolsky, Max Maischein, Abigail, Jesse Luehrs, Tony Cook,
-Dominic Hargreaves, Aaron Crane, Aristotle Pagaltzis and Matthew Horsfall.
+Dominic Hargreaves, Aaron Crane, Aristotle Pagaltzis, Matthew Horsfall
+and Peter Martini.
=head2 PUMPKIN?
Ricardo 5.20.0-RC1 2014-May-16 The 5.20 maintenance track
Ricardo 5.20.0 2014-May-27
+ Steve 5.20.1-RC1 2014-Aug-25
+ Steve 5.20.1-RC2 2014-Sep-07
+ Steve 5.20.1 2014-Sep-14
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
Peter 5.21.3 2014-Aug-20
+ Steve 5.21.4 2014-Sep-20
=head2 SELECTED RELEASE SIZES
XS modules for all categories but C<LC_NUMERIC> get the underlying
locale, and hence any C library functions they call will use that
-underlying locale.
-
-Perl tries to keep C<LC_NUMERIC> set to C<"C">
-because too many modules are unable to cope with the decimal point in a
-floating point number not being a dot (it's a comma in many locales).
-Macros are provided for XS code to temporarily change to use the
-underlying locale when necessary; however buggy code that fails to
-restore when done can break other XS code (but not Perl code) in this
-regard. The API for these macros has not yet been nailed down, but will be
-during the course of v5.21. Send email to
-L<mailto:perl5-porters@perl.org> for guidance.
+underlying locale. For more discussion, see L<perlxs/CAVEATS>.
=back
The default behavior is restored with the S<C<no locale>> pragma, or
upon reaching the end of the block enclosing C<use locale>.
-Note that C<use locale> and C<use locale ':not_characters'> may be
+Note that C<use locale> calls may be
nested, and that what is in effect within an inner scope will revert to
the outer scope's rules at the end of the inner scope.
of the left operand repeated the number of times specified by the right
operand. In list context, if the left operand is enclosed in
parentheses or is a list formed by C<qw/STRING/>, it repeats the list.
-If the right operand is zero or negative, it returns an empty string
+If the right operand is zero or negative (raising a warning on
+negative), it returns an empty string
or an empty list, depending on the context.
X<x>
If the starting delimiter is an unpaired character like C</> or a closing
punctuation, the ending delimiter is same as the starting delimiter.
Therefore a C</> terminates a C<qq//> construct, while a C<]> terminates
-C<qq[]> and C<qq]]> constructs.
+both C<qq[]> and C<qq]]> constructs.
When searching for single-character delimiters, escaped delimiters
and C<\\> are skipped. For example, while searching for terminating C</>,
For constructs with three-part delimiters (C<s///>, C<y///>, and
C<tr///>), the search is repeated once more.
-If the first delimiter is not an opening punctuation, three delimiters must
-be same such as C<s!!!> and C<tr)))>, in which case the second delimiter
+If the first delimiter is not an opening punctuation, the three delimiters must
+be the same, such as C<s!!!> and C<tr)))>,
+in which case the second delimiter
terminates the left part and starts the right part at once.
If the left part is delimited by bracketing punctuation (that is C<()>,
C<[]>, C<{}>, or C<< <> >>), the right part needs another pair of
delimiters such as C<s(){}> and C<tr[]//>. In these cases, whitespace
-and comments are allowed between both parts, though the comment must follow
+and comments are allowed between the two parts, though the comment must follow
at least one whitespace character; otherwise a character expected as the
start of the comment may be regarded as the starting delimiter of the right part.
pack codes C<f>, C<d>, C<F> and C<D>. C<f> and C<d> pack into (or unpack
from) single-precision or double-precision representation as it is provided
by your system. If your systems supports it, C<D> can be used to pack and
-unpack extended-precision floating point values (C<long double>), which
-can offer even more resolution than C<f> or C<d>. C<F> packs an C<NV>,
-which is the floating point type used by Perl internally. (There
-is no such thing as a network representation for reals, so if you want
-to send your real numbers across computer boundaries, you'd better stick
-to ASCII representation, unless you're absolutely sure what's on the other
-end of the line. For the even more adventuresome, you can use the byte-order
-modifiers from the previous section also on floating point codes.)
+unpack (C<long double>) values, which can offer even more resolution
+than C<f> or C<d>. B<Note that there are different long double formats.>
+
+C<F> packs an C<NV>, which is the floating point type used by Perl
+internally.
+
+There is no such thing as a network representation for reals, so if
+you want to send your real numbers across computer boundaries, you'd
+better stick to text representation, possibly using the hexadecimal
+float format (avoiding the decimal conversion loss), unless you're
+absolutely sure what's on the other end of the line. For the even more
+adventuresome, you can use the byte-order modifiers from the previous
+section also on floating point codes.
features, you should contact the perl5-porters mailinglist if you find
an experimental feature useful and want to help shape its future.
+Experimental features must be experimental in two stable releases before being
+marked non-experimental. Experimental features will only have their
+experimental status revoked when they no longer have any design-changing bugs
+open against them and when they have remained unchanged in behavior for the
+entire length of a development cycle. In other words, a feature present in
+v5.20.0 may be marked no longer experimental in v5.22.0 if and only if its
+behavior is unchanged throughout all of v5.21.
+
=item deprecated
If something in the Perl core is marked as B<deprecated>, we may remove it
-------
-* There is an exception to a bracketed character class matching a
-single character only. When the class is to match caselessly under C</i>
-matching rules, and a character that is explicitly mentioned inside the
-class matches a
+* There are two exceptions to a bracketed character class matching a
+single character only. Each requires special handling by Perl to make
+things work:
+
+=over
+
+=item *
+
+When the class is to match caselessly under C</i> matching rules, and a
+character that is explicitly mentioned inside the class matches a
multiple-character sequence caselessly under Unicode rules, the class
-(when not L<inverted|/Negation>) will also match that sequence. For
-example, Unicode says that the letter C<LATIN SMALL LETTER SHARP S>
-should match the sequence C<ss> under C</i> rules. Thus,
+will also match that sequence. For example, Unicode says that the
+letter C<LATIN SMALL LETTER SHARP S> should match the sequence C<ss>
+under C</i> rules. Thus,
'ss' =~ /\A\N{LATIN SMALL LETTER SHARP S}\z/i # Matches
'ss' =~ /\A[aeioust\N{LATIN SMALL LETTER SHARP S}]\z/i # Matches
-For this to happen, the character must be explicitly specified, and not
-be part of a multi-character range (not even as one of its endpoints).
-(L</Character Ranges> will be explained shortly.) Therefore,
+For this to happen, the class must not be inverted (see L</Negation>)
+and the character must be explicitly specified, and not be part of a
+multi-character range (not even as one of its endpoints). (L</Character
+Ranges> will be explained shortly.) Therefore,
'ss' =~ /\A[\0-\x{ff}]\z/i # Doesn't match
'ss' =~ /\A[\0-\N{LATIN SMALL LETTER SHARP S}]\z/i # No match
- 'ss' =~ /\A[\xDF-\xDF]\z/i # Matches on ASCII platforms, since \XDF
- # is LATIN SMALL LETTER SHARP S, and the
- # range is just a single element
+ 'ss' =~ /\A[\xDF-\xDF]\z/i # Matches on ASCII platforms, since
+ # \XDF is LATIN SMALL LETTER SHARP S,
+ # and the range is just a single
+ # element
Note that it isn't a good idea to specify these types of ranges anyway.
+=item *
+
+Some names known to C<\N{...}> refer to a sequence of multiple characters,
+instead of the usual single character. When one of these is included in
+the class, the entire sequence is matched. For example,
+
+ "\N{TAMIL LETTER KA}\N{TAMIL VOWEL SIGN AU}"
+ =~ / ^ [\N{TAMIL SYLLABLE KAU}] $ /x;
+
+matches, because C<\N{TAMIL SYLLABLE KAU}> is a named sequence
+consisting of the two characters matched against. Like the other
+instance where a bracketed class can match multi characters, and for
+similar reasons, the class must not be inverted, and the named sequence
+may not appear in a range, even one where it is both endpoints. If
+these happen, it is a fatal error if the character class is within an
+extended L<C<(?[...])>|/Extended Bracketed Character Classes>
+class; and only the first code point is used (with
+a C<regexp>-type warning raised) otherwise.
+
+=back
+
=head3 Special Characters Inside a Bracketed Character Class
Most characters that are meta characters in regular expressions (that
else don't list it first.
In inverted bracketed character classes, Perl ignores the Unicode rules
-that normally say that certain characters should match a sequence of
-multiple characters under caseless C</i> matching. Following those
-rules could lead to highly confusing situations:
+that normally say that named sequence, and certain characters should
+match a sequence of multiple characters use under caseless C</i>
+matching. Following those rules could lead to highly confusing
+situations:
"ss" =~ /^[^\xDF]+$/ui; # Matches!
says that C<"ss"> is what C<\xDF> matches under C</i>. So which one
"wins"? Do you fail the match because the string has C<ss> or accept it
because it has an C<s> followed by another C<s>? Perl has chosen the
-latter.
+latter. (See note in L</Bracketed Character Classes> above.)
Examples:
=item [6]
-C<\p{SpacePerl}> and C<\p{Space}> match identically starting with Perl
+C<\p{XPerlSpace}> and C<\p{Space}> match identically starting with Perl
v5.18. In earlier versions, these differ only in that in non-locale
-matching, C<\p{SpacePerl}> does not match the vertical tab, C<\cK>.
+matching, C<\p{XPerlSpace}> does not match the vertical tab, C<\cK>.
Same for the two ASCII-only range forms.
=back
=back
-The C<E<sol>x> processing within this class is an extended form.
-Besides the characters that are considered white space in normal C</x>
-processing, there are 5 others, recommended by the Unicode standard:
-
- U+0085 NEXT LINE
- U+200E LEFT-TO-RIGHT MARK
- U+200F RIGHT-TO-LEFT MARK
- U+2028 LINE SEPARATOR
- U+2029 PARAGRAPH SEPARATOR
-
Note that skipping white space applies only to the interior of this
construct. There must not be any space between any of the characters
that form the initial C<(?[>. Nor may there be space between the
mode>, when it detects its program running with differing real and effective
user or group IDs. The setuid bit in Unix permissions is mode 04000, the
setgid bit mode 02000; either or both may be set. You can also enable taint
-mode explicitly by using the B<-T> command line flag. This flag is
+mode explicitly by using the B<-T> command line flag. This flag is
I<strongly> suggested for server programs and any program run on behalf of
-someone else, such as a CGI script. Once taint mode is on, it's on for
+someone else, such as a CGI script. Once taint mode is on, it's on for
the remainder of your script.
While in this mode, Perl takes special precautions called I<taint
When the taint mode (C<-T>) is in effect, the "." directory is removed
from C<@INC>, and the environment variables C<PERL5LIB> and C<PERLLIB>
-are ignored by Perl. You can still adjust C<@INC> from outside the
+are ignored by Perl. You can still adjust C<@INC> from outside the
program by using the C<-I> command line option as explained in
-L<perlrun>. The two environment variables are ignored because
+L<perlrun>. The two environment variables are ignored because
they are obscured, and a user running a program could be unaware that
they are set, whereas the C<-I> option is clearly visible and
therefore permitted.
perl -Mlib=/foo program
The benefit of using C<-Mlib=/foo> over C<-I/foo>, is that the former
-will automagically remove any duplicated directories, while the later
+will automagically remove any duplicated directories, while the latter
will not.
Note that if a tainted string is added to C<@INC>, the following
The PATH isn't the only environment variable which can cause problems.
Because some shells may use the variables IFS, CDPATH, ENV, and
BASH_ENV, Perl checks that those are either empty or untainted when
-starting subprocesses. You may wish to add something like this to your
+starting subprocesses. You may wish to add something like this to your
setid and taint-checking scripts.
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
care whether they use tainted values. Make judicious use of the file
tests in dealing with any user-supplied filenames. When possible, do
opens and such B<after> properly dropping any special user (or group!)
-privileges. Perl doesn't prevent you from opening tainted filenames for reading,
+privileges. Perl doesn't prevent you from
+opening tainted filenames for reading,
so be careful what you print out. The tainting mechanism is intended to
prevent stupid mistakes, not to remove the need for thought.
not be considered bullet-proof, though: it will not prevent the foreign
code to set up infinite loops, allocate gigabytes of memory, or even
abusing perl bugs to make the host interpreter crash or behave in
-unpredictable ways. In any case it's better avoided completely if you're
+unpredictable ways. In any case it's better avoided completely if you're
really concerned about security.
=head2 Security Bugs
Hash Algorithm - Hash algorithms like the one used in Perl are well
known to be vulnerable to collision attacks on their hash function.
Such attacks involve constructing a set of keys which collide into
-the same bucket producing inefficient behavior. Such attacks often
+the same bucket producing inefficient behavior. Such attacks often
depend on discovering the seed of the hash function used to map the
-keys to buckets. That seed is then used to brute-force a key set which
-can be used to mount a denial of service attack. In Perl 5.8.1 changes
+keys to buckets. That seed is then used to brute-force a key set which
+can be used to mount a denial of service attack. In Perl 5.8.1 changes
were introduced to harden Perl to such attacks, and then later in
Perl 5.18.0 these features were enhanced and additional protections
added.
At the time of this writing, Perl 5.18.0 is considered to be
well-hardened against algorithmic complexity attacks on its hash
-implementation. This is largely owed to the following measures
+implementation. This is largely owed to the following measures
mitigate attacks:
=over 4
=item Hash Seed Randomization
In order to make it impossible to know what seed to generate an attack
-key set for, this seed is randomly initialized at process start. This
+key set for, this seed is randomly initialized at process start. This
may be overridden by using the PERL_HASH_SEED environment variable, see
-L<perlrun/PERL_HASH_SEED>. This environment variable controls how
+L<perlrun/PERL_HASH_SEED>. This environment variable controls how
items are actually stored, not how they are presented via
C<keys>, C<values> and C<each>.
Modifying a hash by insertion will change the iteration order of that hash.
This behavior can be overridden by using C<hash_traversal_mask()> from
L<Hash::Util> or by using the PERL_PERTURB_KEYS environment variable,
-see L<perlrun/PERL_PERTURB_KEYS>. Note that this feature controls the
+see L<perlrun/PERL_PERTURB_KEYS>. Note that this feature controls the
"visible" order of the keys, and not the actual order they are stored in.
=item Bucket Order Perturbance
When items collide into a given hash bucket the order they are stored in
-the chain is no longer predictable in Perl 5.18. This has the intention
-to make it harder to observe a collisions. This behavior can be overridden by using
+the chain is no longer predictable in Perl 5.18. This
+has the intention to make it harder to observe a
+collision. This behavior can be overridden by using
the PERL_PERTURB_KEYS environment variable, see L<perlrun/PERL_PERTURB_KEYS>.
=item New Default Hash Function
The source code includes multiple hash algorithms to choose from. While we
believe that the default perl hash is robust to attack, we have included the
-hash function Siphash as a fall-back option. At the time of release of
+hash function Siphash as a fall-back option. At the time of release of
Perl 5.18.0 Siphash is believed to be of cryptographic strength. This is
not the default as it is much slower than the default hash.
=back
Without compiling a special Perl, there is no way to get the exact same
-behavior of any versions prior to Perl 5.18.0. The closest one can get
+behavior of any versions prior to Perl 5.18.0. The closest one can get
is by setting PERL_PERTURB_KEYS to 0 and setting the PERL_HASH_SEED
-to a known value. We do not advise those settings for production use
+to a known value. We do not advise those settings for production use
due to the above security considerations.
B<Perl has never guaranteed any ordering of the hash keys>, and
one large indistinguishable list.
If no C<return> is found and if the last statement is an expression, its
-value is returned. If the last statement is a loop control structure
-like a C<foreach> or a C<while>, the returned value is unspecified. The
+value is returned. If the last statement is a loop control structure
+like a C<foreach> or a C<while>, the returned value is unspecified. The
empty sub returns the empty list.
X<subroutine, return value> X<return value> X<return>
all capitals is a loosely-held convention meaning it will be called
indirectly by the run-time system itself, usually due to a triggered event.
Subroutines whose name start with a left parenthesis are also reserved the
-same way. The following is a list of some subroutines that currently do
+same way. The following is a list of some subroutines that currently do
special, pre-defined things.
=over
X<state> X<state variable> X<static> X<variable, persistent> X<variable, static> X<closure>
There are two ways to build persistent private variables in Perl 5.10.
-First, you can simply use the C<state> feature. Or, you can use closures,
+First, you can simply use the C<state> feature. Or, you can use closures,
if you want to stay compatible with releases older than 5.10.
=head3 Persistent variables via state()
It's also worth taking a moment to explain what happens when you
C<local>ize a member of a composite type (i.e. an array or hash element).
-In this case, the element is C<local>ized I<by name>. This means that
+In this case, the element is C<local>ized I<by name>. This means that
when the scope of the C<local()> ends, the saved value will be
restored to the hash element whose key was named in the C<local()>, or
the array element whose index was named in the C<local()>. If that
You can use the C<delete local $array[$idx]> and C<delete local $hash{key}>
constructs to delete a composite type entry for the current block and restore
-it when it ends. They return the array/hash value before the localization,
+it when it ends. They return the array/hash value before the localization,
which means that they are respectively equivalent to
do {
$val
}
-except that for those the C<local> is scoped to the C<do> block. Slices are
+except that for those the C<local> is
+scoped to the C<do> block. Slices are
also accepted.
my %hash = (
The scalar/list context for the subroutine and for the right-hand
side of assignment is determined as if the subroutine call is replaced
-by a scalar. For example, consider:
+by a scalar. For example, consider:
data(2,3) = get_data(3,4);
all the subroutines are called in a list context.
Lvalue subroutines are convenient, but you have to keep in mind that,
-when used with objects, they may violate encapsulation. A normal
+when used with objects, they may violate encapsulation. A normal
mutator can check the supplied argument before setting the attribute
-it is protecting, an lvalue subroutine cannot. If you require any
+it is protecting, an lvalue subroutine cannot. If you require any
special processing when storing and retrieving the values, consider
using the CPAN module Sentinel or something similar.
that must start with that character (optionally preceded by C<my>,
C<our> or C<local>), with the exception of C<$>, which will
accept any scalar lvalue expression, such as C<$foo = 7> or
-C<< my_function()->[0] >>. The value passed as part of C<@_> will be a
+C<< my_function()->[0] >>. The value passed as part of C<@_> will be a
reference to the actual argument given in the subroutine call,
obtained by applying C<\> to that argument.
You can use the C<\[]> backslash group notation to specify more than one
-allowed argument type. For example:
+allowed argument type. For example:
sub myref (\[$@%&*])
As alluded to earlier you can also declare inlined subs dynamically at
BEGIN time if their body consists of a lexically-scoped scalar which
-has no other references. Only the first example here will be inlined:
+has no other references. Only the first example here will be inlined:
BEGIN {
my $var = 1;
};
If you redefine a subroutine that was eligible for inlining, you'll
-get a warning by default. You can use this warning to tell whether or
+get a warning by default. You can use this warning to tell whether or
not a particular subroutine is considered inlinable, since it's
different than the warning for overriding non-inlined subroutines:
C<glob>, the C<< <*> >> glob operator is overridden as well.
In a similar fashion, overriding the C<readline> function also overrides
-the equivalent I/O operator C<< <FILEHANDLE> >>. Also, overriding
+the equivalent I/O operator C<< <FILEHANDLE> >>. Also, overriding
C<readpipe> also overrides the operators C<``> and C<qx//>.
Finally, some built-ins (e.g. C<exists> or C<grep>) can't be overridden.
case, it doesn't think the C<...> is an ellipsis because it's expecting an
expression instead of a statement:
- @transformed = map { ... } @input; # syntax error
+ @transformed = map { ... } @input; # syntax error
-You can use a C<;> inside your block to denote that the C<{ ... }> is a
-block and not a hash reference constructor. Now the ellipsis works:
+Inside your block, you can use a C<;> before the ellipsis to denote that the
+C<{ ... }> is a block and not a hash reference constructor. Now the ellipsis
+works:
- @transformed = map {; ... } @input; # ; disambiguates
-
- @transformed = map { ...; } @input; # ; disambiguates
+ @transformed = map {; ... } @input; # ';' disambiguates
Note: Some folks colloquially refer to this bit of punctuation as a
"yada-yada" or "triple-dot", but its true name
-is actually an ellipsis. Perl does not yet
-accept the Unicode version, U+2026 HORIZONTAL ELLIPSIS, as an alias for
-C<...>, but someday it may.
+is actually an ellipsis.
=head2 PODs: Embedded Documentation
X<POD> X<documentation>
const char * const name = CopSTASHPV(PL_curcop);
gv = newGVgen_flags(name,
HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
+ SvREFCNT_inc_simple_void_NN(gv);
}
prepare_SV_for_RV(sv);
SvRV_set(sv, MUTABLE_SV(gv));
CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
if (cv) NOOP;
else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
- cv = MUTABLE_CV(gv);
+ cv = SvTYPE(SvRV(gv)) == SVt_PVCV
+ ? MUTABLE_CV(SvRV(gv))
+ : MUTABLE_CV(gv);
}
else
cv = MUTABLE_CV(&PL_sv_undef);
SvREFCNT_inc_void_NN(sv);
}
else if (SvPADTMP(sv)) {
- assert(!IS_PADGV(sv));
sv = newSVsv(sv);
}
else {
RETPUSHYES;
}
+
+/* also used for: pp_transr() */
+
PP(pp_trans)
{
dSP; dTARG;
}
}
+
+/* also used for: pp_schomp() */
+
PP(pp_schop)
{
dSP; dTARGET;
RETURN;
}
+
+/* also used for: pp_chomp() */
+
PP(pp_chop)
{
dSP; dMARK; dTARGET; dORIGMARK;
if (!sv)
RETPUSHUNDEF;
- SV_CHECK_THINKFIRST_COW_DROP(sv);
+ if (SvTHINKFIRST(sv))
+ sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
switch (SvTYPE(sv)) {
case SVt_NULL:
));
/* FALLTHROUGH */
case SVt_PVFM:
- {
/* let user-undef'd sub keep its identity */
- GV* const gv = CvGV((const CV *)sv);
- HEK * const hek = CvNAME_HEK((CV *)sv);
- if (hek) share_hek_hek(hek);
- cv_undef(MUTABLE_CV(sv));
- if (gv) CvGV_set(MUTABLE_CV(sv), gv);
- else if (hek) {
- SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek;
- CvNAMED_on(sv);
- }
- }
+ cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
break;
case SVt_PVGV:
assert(isGV_with_GP(sv));
RETPUSHUNDEF;
}
+
+/* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */
+
PP(pp_postinc)
{
dSP; dTARGET;
#else
if (*SP) {
if (mod && SvPADTMP(*SP)) {
- assert(!IS_PADGV(*SP));
*SP = sv_mortalcopy(*SP);
}
SvTEMP_off((*SP));
RETURN;
}
+
+/* also used for: pp_sge() pp_sgt() pp_slt() */
+
PP(pp_sle)
{
dSP;
}
}
+
+/* also used for: pp_bit_xor() */
+
PP(pp_bit_or)
{
dSP; dATARGET;
}
}
+
+/* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
+
PP(pp_sin)
{
dSP; dTARGET;
- int amg_type = sin_amg;
+ int amg_type = fallback_amg;
const char *neg_report = NULL;
- NV (*func)(NV) = Perl_sin;
const int op_type = PL_op->op_type;
switch (op_type) {
- case OP_COS:
- amg_type = cos_amg;
- func = Perl_cos;
- break;
- case OP_EXP:
- amg_type = exp_amg;
- func = Perl_exp;
- break;
- case OP_LOG:
- amg_type = log_amg;
- func = Perl_log;
- neg_report = "log";
- break;
- case OP_SQRT:
- amg_type = sqrt_amg;
- func = Perl_sqrt;
- neg_report = "sqrt";
- break;
+ case OP_SIN: amg_type = sin_amg; break;
+ case OP_COS: amg_type = cos_amg; break;
+ case OP_EXP: amg_type = exp_amg; break;
+ case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
+ case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
}
+ assert(amg_type != fallback_amg);
tryAMAGICun_MG(amg_type, 0);
{
SV * const arg = POPs;
const NV value = SvNV_nomg(arg);
- if (neg_report) {
+ NV result = NV_NAN;
+ if (neg_report) { /* log or sqrt */
if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
SET_NUMERIC_STANDARD();
/* diag_listed_as: Can't take log of %g */
DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
}
}
- XPUSHn(func(value));
+ switch (op_type) {
+ default:
+ case OP_SIN: result = Perl_sin(value); break;
+ case OP_COS: result = Perl_cos(value); break;
+ case OP_EXP: result = Perl_exp(value); break;
+ case OP_LOG: result = Perl_log(value); break;
+ case OP_SQRT: result = Perl_sqrt(value); break;
+ }
+ XPUSHn(result);
RETURN;
}
}
RETURN;
}
+
+/* also used for: pp_hex() */
+
PP(pp_oct)
{
dSP; dTARGET;
tmps++, len--;
if (*tmps == '0')
tmps++, len--;
- if (*tmps == 'x' || *tmps == 'X') {
+ if (isALPHA_FOLD_EQ(*tmps, 'x')) {
hex:
result_uv = grok_hex (tmps, &len, &flags, &result_nv);
}
- else if (*tmps == 'b' || *tmps == 'B')
+ else if (isALPHA_FOLD_EQ(*tmps, 'b'))
result_uv = grok_bin (tmps, &len, &flags, &result_nv);
else
result_uv = grok_oct (tmps, &len, &flags, &result_nv);
RETURN;
}
+
+/* also used for: pp_rindex() */
+
PP(pp_index)
{
dSP; dTARGET;
SV *top = POPs;
SvGETMAGIC(top);
- if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
- && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
- ||
- ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
- && SvNV_nomg(top) < 0.0))) {
+ if (SvNOK(top) && Perl_isinfnan(SvNV(top))) {
+ if (ckWARN(WARN_UTF8)) {
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ "Invalid number (%"NVgf") in chr", SvNV(top));
+ }
+ value = UNICODE_REPLACEMENT;
+ }
+ else {
+ if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
+ && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
+ ||
+ ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
+ && SvNV_nomg(top) < 0.0))) {
if (ckWARN(WARN_UTF8)) {
if (SvGMAGICAL(top)) {
SV *top2 = sv_newmortal();
sv_setsv_nomg(top2, top);
top = top2;
}
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "Invalid negative number (%"SVf") in chr", SVfARG(top));
- }
- value = UNICODE_REPLACEMENT;
- } else {
- value = SvUV_nomg(top);
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ "Invalid negative number (%"SVf") in chr", SVfARG(top));
+ }
+ value = UNICODE_REPLACEMENT;
+ } else {
+ value = SvUV_nomg(top);
+ }
}
SvUPGRADE(TARG,SVt_PV);
/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
* most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
+
+/* also used for: pp_lcfirst() */
+
PP(pp_ucfirst)
{
/* Actually is both lcfirst() and ucfirst(). Only the first character
RETURN;
}
+
/* Smart dereferencing for keys, values and each */
+
+/* also used for: pp_reach() pp_rvalues() */
+
PP(pp_rkeys)
{
dSP;
RETURN;
}
+/* also used for: pp_avalues()*/
PP(pp_akeys)
{
dSP;
if (!(*lelem = firstrelem[ix]))
*lelem = &PL_sv_undef;
else if (mod && SvPADTMP(*lelem)) {
- assert(!IS_PADGV(*lelem));
*lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
}
}
RETURN;
}
+/* also used for: pp_pop()*/
PP(pp_shift)
{
dSP;
}
+/* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
+ * that aren't implemented on a particular platform */
+
PP(unimplemented_op)
{
const Optype op_type = PL_op->op_type;
#define ARGTARG PL_op->op_targ
- /* See OPpTARGET_MY: */
-#define MAXARG (PL_op->op_private & 15)
+#define MAXARG (PL_op->op_private & OPpARG4_MASK)
#define SWITCHSTACK(f,t) \
STMT_START { \
case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
arg = *fpc++;
-#if defined(USE_LONG_DOUBLE)
fmt = (const char *)
- ((arg & FORM_NUM_POINT) ?
- "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
-#else
- fmt = (const char *)
- ((arg & FORM_NUM_POINT) ?
- "%#0*.*f" : "%0*.*f");
-#endif
+ ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
goto ff_dec;
case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
arg = *fpc++;
-#if defined(USE_LONG_DOUBLE)
fmt = (const char *)
- ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
-#else
- fmt = (const char *)
- ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
-#endif
+ ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
ff_dec:
/* If the field is marked with ^ and the value is undefined,
blank it out. */
int len;
DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
+#ifdef USE_QUADMATH
+ {
+ const char* qfmt = quadmath_format_single(fmt);
+ int len;
+ if (!qfmt)
+ Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
+ len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
+ if (len == -1)
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+ if (qfmt != fmt)
+ Safefree(fmt);
+ }
+#else
/* we generate fmt ourselves so it is safe */
GCC_DIAG_IGNORE(-Wformat-nonliteral);
len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
- PERL_MY_SNPRINTF_POST_GUARD(len, max);
GCC_DIAG_RESTORE;
+#endif
+ PERL_MY_SNPRINTF_POST_GUARD(len, max);
RESTORE_LC_NUMERIC();
}
t += fieldsize;
src = PL_stack_base[*PL_markstack_ptr];
if (SvPADTMP(src)) {
- assert(!IS_PADGV(src));
src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
PL_tmps_floor++;
}
/* set $_ to the new source item */
src = PL_stack_base[PL_markstack_ptr[-1]];
if (SvPADTMP(src)) {
- assert(!IS_PADGV(src));
src = sv_mortalcopy(src);
}
SvTEMP_off(src);
SV *namesv;
PERL_CONTEXT *cx;
SV **newsp;
+#ifdef DEBUGGING
COP *oldcop;
+#endif
JMPENV *restartjmpenv;
OP *restartop;
}
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
+#ifdef DEBUGGING
oldcop = cx->blk_oldcop;
+#endif
restartjmpenv = cx->blk_eval.cur_top_env;
restartop = cx->blk_eval.retop;
LEAVE;
- /* LEAVE could clobber PL_curcop (see save_re_context())
- * XXX it might be better to find a way to avoid messing with
- * PL_curcop in save_re_context() instead, but this is a more
- * minimal fix --GSAR */
- PL_curcop = oldcop;
-
if (optype == OP_REQUIRE) {
+ assert (PL_curcop == oldcop);
(void)hv_store(GvHVn(PL_incgv),
SvPVX_const(namesv),
SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
if (!has_arg)
RETURN;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- GV * const cvgv = CvGV(dbcx->blk_sub.cv);
/* So is ccstack[dbcxix]. */
- if (cvgv && isGV(cvgv)) {
- SV * const sv = newSV(0);
- gv_efullname3(sv, cvgv, NULL);
- mPUSHs(sv);
+ if (CvHASGV(dbcx->blk_sub.cv)) {
+ PUSHs(cv_name(dbcx->blk_sub.cv, 0));
PUSHs(boolSV(CxHASARGS(cx)));
}
else {
return NORMAL;
}
+/* S_leave_common: Common code that many functions in this file use on
+ scope exit. */
+
/* SVs on the stack that have any of the flags passed in are left as is.
Other SVs are protected via the mortals stack if lvalue is true, and
- copied otherwise. */
+ copied otherwise.
+
+ Also, taintedness is cleared.
+*/
STATIC SV **
-S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
+S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme,
U32 flags, bool lvalue)
{
bool padtmp = 0;
- PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
+ PERL_ARGS_ASSERT_LEAVE_COMMON;
+ TAINT_NOT;
if (flags & SVs_PADTMP) {
flags &= ~SVs_PADTMP;
padtmp = 1;
gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
- TAINT_NOT;
- SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
+ SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP,
PL_op->op_private & OPpLVALUE);
PL_curpm = newpm; /* Don't pop $1 et al till now */
SvGETMAGIC(sv);
SvGETMAGIC(right);
if (RANGE_IS_NUMERIC(sv,right)) {
+ NV nv;
cx->cx_type &= ~CXTYPEMASK;
cx->cx_type |= CXt_LOOP_LAZYIV;
/* Make sure that no-one re-orders cop.h and breaks our
assumptions */
assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
#ifdef NV_PRESERVES_UV
- if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
- (SvNV_nomg(sv) > (NV)IV_MAX)))
+ if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) < (NV)IV_MIN) ||
+ (nv > (NV)IV_MAX)))
||
- (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
- (SvNV_nomg(right) < (NV)IV_MIN))))
+ (SvOK(right) && (((nv = SvNV_nomg(right)) > (NV)IV_MAX) ||
+ (nv < (NV)IV_MIN))))
#else
- if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
+ if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) <= (NV)IV_MIN)
||
- ((SvNV_nomg(sv) > 0) &&
- ((SvUV_nomg(sv) > (UV)IV_MAX) ||
- (SvNV_nomg(sv) > (NV)UV_MAX)))))
+ ((nv > 0) &&
+ ((nv > (NV)UV_MAX) ||
+ (SvUV_nomg(sv) > (UV)IV_MAX)))))
||
- (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
+ (SvOK(right) && (((nv = SvNV_nomg(right)) <= (NV)IV_MIN)
||
- ((SvNV_nomg(right) > 0) &&
- ((SvUV_nomg(right) > (UV)IV_MAX) ||
- (SvNV_nomg(right) > (NV)UV_MAX))
+ ((nv > 0) &&
+ ((nv > (NV)UV_MAX) ||
+ (SvUV_nomg(right) > (UV)IV_MAX))
))))
#endif
DIE(aTHX_ "Range iterator outside integer range");
mark = newsp;
newsp = PL_stack_base + cx->blk_loop.resetsp;
- TAINT_NOT;
- SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0,
+ SP = leave_common(newsp, SP, MARK, gimme, 0,
PL_op->op_private & OPpLVALUE);
PUTBACK;
return 0;
}
-PP(pp_goto) /* also pp_dump */
+
+/* also used for: pp_dump() */
+
+PP(pp_goto)
{
dVAR; dSP;
OP *retop = NULL;
return TRUE;
}
+
+/* also used for: pp_dofile() */
+
PP(pp_require)
{
dSP;
retop = cx->blk_eval.retop;
evalcv = cx->blk_eval.cv;
- TAINT_NOT;
- SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
+ SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
gimme, SVs_TEMP, FALSE);
PL_curpm = newpm; /* Don't pop $1 et al till now */
POPEVAL(cx);
PERL_UNUSED_VAR(optype);
- TAINT_NOT;
- SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
+ SP = leave_common(newsp, SP, newsp, gimme,
SVs_PADTMP|SVs_TEMP, FALSE);
PL_curpm = newpm; /* Don't pop $1 et al till now */
POPBLOCK(cx,newpm);
assert(CxTYPE(cx) == CXt_GIVEN);
- TAINT_NOT;
- SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
+ SP = leave_common(newsp, SP, newsp, gimme,
SVs_PADTMP|SVs_TEMP, FALSE);
PL_curpm = newpm; /* Don't pop $1 et al till now */
POPBLOCK(cx,newpm);
assert(CxTYPE(cx) == CXt_WHEN);
- TAINT_NOT;
- SP = adjust_stack_on_leave(newsp, SP, newsp, gimme,
+ SP = leave_common(newsp, SP, newsp, gimme,
SVs_PADTMP|SVs_TEMP, FALSE);
PL_curpm = newpm; /* pop $1 et al */
PP(pp_nextstate)
{
PL_curcop = (COP*)PL_op;
+ PL_sawalias = 0;
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
PUSHs(save_scalar(cGVOP_gv));
else
PUSHs(GvSVn(cGVOP_gv));
+ if (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv))
+ PL_sawalias = TRUE;
RETURN;
}
+
+/* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
+
PP(pp_null)
{
return NORMAL;
{
dSP;
XPUSHs(MUTABLE_SV(cGVOP_gv));
+ if (isGV(cGVOP_gv)
+ && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)))
+ PL_sawalias = TRUE;
RETURN;
}
+
+/* also used for: pp_andassign() */
+
PP(pp_and)
{
PERL_ASYNC_CHECK();
RETURN;
}
+
+/* also used for: pp_i_predec() pp_i_preinc() pp_predec() */
+
PP(pp_preinc)
{
dSP;
return NORMAL;
}
+
+/* also used for: pp_orassign() */
+
PP(pp_or)
{
dSP;
}
}
+
+/* also used for: pp_dor() pp_dorassign() */
+
PP(pp_defined)
{
dSP;
}
}
+
+/* also used for: pp_aelemfast_lex() */
+
PP(pp_aelemfast)
{
dSP;
/* Oversized hot code. */
+/* also used for: pp_say() */
+
PP(pp_print)
{
dSP; dMARK; dORIGMARK;
RETURN;
}
+
+/* also used for: pp_rv2hv() */
+
PP(pp_rv2av)
{
dSP; dTOPss;
* Don't bother if LHS is just an empty hash or array.
*/
- if ( (PL_op->op_private & OPpASSIGN_COMMON)
+ if ( (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias)
&& (
firstlelem != lastlelem
|| ! ((sv = *firstlelem))
Perl_croak(aTHX_ "Use of freed value in iteration");
}
if (SvPADTMP(sv)) {
- assert(!IS_PADGV(sv));
sv = newSVsv(sv);
}
else {
src = PL_stack_base[*PL_markstack_ptr];
if (SvPADTMP(src)) {
- assert(!IS_PADGV(src));
src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
PL_tmps_floor++;
}
SV* sub_name;
/* anonymous or undef'd function leaves us no recourse */
- if (CvANON(cv) || !(gv = CvGV(cv))) {
- if (CvNAMED(cv))
- DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
- HEKfARG(CvNAME_HEK(cv)));
+ if (CvLEXICAL(cv) && CvHASGV(cv))
+ DIE(aTHX_ "Undefined subroutine &%"SVf" called",
+ SVfARG(cv_name(cv, NULL)));
+ if (CvANON(cv) || !CvHASGV(cv)) {
DIE(aTHX_ "Undefined subroutine called");
}
/* autoloaded stub? */
- if (cv != GvCV(gv)) {
+ if (cv != GvCV(gv = CvGV(cv))) {
cv = GvCV(gv);
}
/* should call AUTOLOAD now? */
if (*MARK)
{
if (SvPADTMP(*MARK)) {
- assert(!IS_PADGV(*MARK));
*MARK = sv_mortalcopy(*MARK);
}
SvTEMP_off(*MARK);
while (items--) {
mark++;
if (*mark && SvPADTMP(*mark)) {
- assert(!IS_PADGV(*mark));
*mark = sv_mortalcopy(*mark);
}
}
if (CvANON(cv))
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
else {
- HEK *const hek = CvNAME_HEK(cv);
- SV *tmpstr;
- if (hek) {
- tmpstr = sv_2mortal(newSVhek(hek));
- }
- else {
- tmpstr = sv_newmortal();
- gv_efullname3(tmpstr, CvGV(cv), NULL);
- }
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
- SVfARG(tmpstr));
+ SVfARG(cv_name(cv,NULL)));
}
}
GV* iogv;
STRLEN packlen;
const char * const packname = SvPV_nomg_const(sv, packlen);
- const bool packname_is_utf8 = !!SvUTF8(sv);
- const HE* const he =
- (const HE *)hv_common(
- PL_stashcache, NULL, packname, packlen,
- packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
- );
-
- if (he) {
- stash = INT2PTR(HV*,SvIV(HeVAL(he)));
- DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
- (void*)stash, SVfARG(sv)));
- goto fetch;
- }
+ const U32 packname_utf8 = SvUTF8(sv);
+ stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
+ if (stash) goto fetch;
if (!(iogv = gv_fetchpvn_flags(
- packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
+ packname, packlen, packname_utf8, SVt_PVIO
)) ||
!(ob=MUTABLE_SV(GvIO(iogv))))
{
SVfARG(meth));
}
/* assume it's a package name */
- stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
- if (!stash)
- packsv = sv;
- else {
- SV* const ref = newSViv(PTR2IV(stash));
- (void)hv_store(PL_stashcache, packname,
- packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
- DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
- (void*)stash, SVfARG(sv)));
- }
+ stash = gv_stashpvn(packname, packlen, packname_utf8);
+ if (!stash) packsv = sv;
goto fetch;
}
/* it _is_ a filehandle name -- replace with a reference */
while (len-- > 0) {
IV aiv;
fromstr = NEXTFROM;
- aiv = SvIV(fromstr);
+ if (SvNOK(fromstr) && Perl_isinfnan(SvNV(fromstr))) {
+ /* 255 is a pretty arbitrary choice, but with
+ * inf/-inf/nan and 256 bytes there is not much room. */
+ aiv = 255;
+ Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
+ "Character in 'c' format overflow in pack");
+ }
+ else
+ aiv = SvIV(fromstr);
if ((-128 > aiv || aiv > 127))
Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
"Character in 'c' format wrapped in pack");
while (len-- > 0) {
IV aiv;
fromstr = NEXTFROM;
- aiv = SvIV(fromstr);
+ if (SvNOK(fromstr) && Perl_isinfnan(SvNV(fromstr))) {
+ /* See the 'c' case. */
+ aiv = 255;
+ Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
+ "Character in 'C' format overflow in pack");
+ }
+ else
+ aiv = SvIV(fromstr);
if ((0 > aiv || aiv > 0xff))
Perl_ck_warner(aTHX_ packWARN(WARN_PACK),
"Character in 'C' format wrapped in pack");
for (i=max; i > 0 ; i--) {
if ((*p1 = *p2++)) { /* Weed out nulls. */
if (copytmps && SvPADTMP(*p1)) {
- assert(!IS_PADGV(*p1));
*p1 = sv_mortalcopy(*p1);
}
SvTEMP_off(*p1);
RETURN;
}
+
+/* also used for: pp_dbmclose() */
+
PP(pp_untie)
{
dSP;
RETURN;
}
+
+/* also used for: pp_read() and pp_recv() (where supported) */
+
PP(pp_sysread)
{
dSP; dMARK; dORIGMARK; dTARGET;
RETPUSHUNDEF;
}
+
+/* also used for: pp_send() where defined */
+
PP(pp_syswrite)
{
dSP; dMARK; dORIGMARK; dTARGET;
RETURN;
}
+
+/* also used for: pp_seek() */
+
PP(pp_sysseek)
{
dSP;
}
}
+
+/* also used for: pp_fcntl() */
+
PP(pp_ioctl)
{
dSP; dTARGET;
#ifdef HAS_SOCKET
+/* also used for: pp_connect() */
+
PP(pp_bind)
{
dSP;
RETPUSHUNDEF;
}
+
+/* also used for: pp_gsockopt() */
+
PP(pp_ssockopt)
{
dSP;
}
+
+/* also used for: pp_getsockname() */
+
PP(pp_getpeername)
{
dSP;
/* Stat calls. */
+/* also used for: pp_lstat() */
+
PP(pp_stat)
{
dSP;
}
+/* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
+ * pp_ftrwrite() */
+
PP(pp_ftrread)
{
I32 result;
/* Not const, because things tweak this below. Not bool, because there's
- no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
+ no guarantee that OPpFT_ACCESS is <= CHAR_MAX */
#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
I32 use_access = PL_op->op_private & OPpFT_ACCESS;
/* Giving some sort of initial value silences compilers. */
FT_RETURNNO;
}
+
+/* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
+
PP(pp_ftis)
{
I32 result;
}
}
+
+/* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
+ * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
+ * pp_ftsuid() pp_ftsvtx() pp_ftzero() */
+
PP(pp_ftrowned)
{
I32 result;
FT_RETURNNO;
}
+
+/* also used for: pp_ftbinary() */
+
PP(pp_fttext)
{
I32 i;
}
/* now scan s to look for textiness */
- /* XXX ASCII dependent code */
#if defined(DOSISH) || defined(USEMYBINMODE)
/* ignore trailing ^Z on short files */
--len;
#endif
+ assert(len);
+ if (! is_ascii_string((U8 *) s, len)) {
+ const U8 *ep;
+
+ /* Here contains a non-ASCII. See if the entire string is UTF-8. But
+ * the buffer may end in a partial character, so consider it UTF-8 if
+ * the first non-UTF8 char is an ending partial */
+ if (is_utf8_string_loc((U8 *) s, len, &ep)
+ || ep + UTF8SKIP(ep) > (U8 *) (s + len))
+ {
+ if (PL_op->op_type == OP_FTTEXT) {
+ FT_RETURNYES;
+ }
+ else {
+ FT_RETURNNO;
+ }
+ }
+ }
+
+ /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for
+ * things that wouldn't be in ASCII text or rich ASCII text. Count these
+ * in 'odd' */
for (i = 0; i < len; i++, s++) {
if (!*s) { /* null never allowed in text */
odd += len;
break;
}
-#ifdef EBCDIC
- else if (!(isPRINT(*s) || isSPACE(*s)))
- odd++;
-#else
- else if (*s & 128) {
#ifdef USE_LOCALE_CTYPE
- if (IN_LC_RUNTIME(LC_CTYPE) && isALPHA_LC(*s))
+ if (IN_LC_RUNTIME(LC_CTYPE)) {
+ if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
continue;
+ }
+ }
+ else
#endif
- /* utf8 characters don't count as odd */
- if (UTF8_IS_START(*s)) {
- int ulen = UTF8SKIP(s);
- if (ulen < len - i) {
- int j;
- for (j = 1; j < ulen; j++) {
- if (!UTF8_IS_CONTINUATION(s[j]))
- goto not_utf8;
- }
- --ulen; /* loop does extra increment */
- s += ulen;
- i += ulen;
- continue;
- }
- }
- not_utf8:
- odd++;
- }
- else if (*s < 32 &&
- *s != '\n' && *s != '\r' && *s != '\b' &&
- *s != '\t' && *s != '\f' && *s != 27)
- odd++;
-#endif
+ if (isPRINT_A(*s)
+ /* VT occurs so rarely in text, that we consider it odd */
+ || (isSPACE_A(*s) && *s != VT_NATIVE)
+
+ /* But there is a fair amount of backspaces and escapes in
+ * some text */
+ || *s == '\b'
+ || *s == ESC_NATIVE)
+ {
+ continue;
+ }
+ odd++;
}
if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
RETURN;
}
+
+/* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
+
PP(pp_chown)
{
dSP; dMARK; dTARGET;
RETURN;
}
+
+/* also used for: pp_symlink() */
+
#if defined(HAS_LINK) || defined(HAS_SYMLINK)
PP(pp_link)
{
RETURN;
}
#else
+
+/* also used for: pp_symlink() */
+
PP(pp_link)
{
/* Have neither. */
/* Sun Dec 29 12:00:00 2147483647 */
#define TIME_UPPER_BOUND 67767976233316800.0
+
+/* also used for: pp_localtime() */
+
PP(pp_gmtime)
{
dSP;
if (err == NULL)
RETPUSHUNDEF;
else {
- mPUSHs(Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
+ mPUSHs(Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %"IVdf,
dayname[tmbuf.tm_wday],
monname[tmbuf.tm_mon],
tmbuf.tm_mday,
tmbuf.tm_hour,
tmbuf.tm_min,
tmbuf.tm_sec,
- /* XXX newSVpvf()'s %lld type is broken,
- * so cheat with a double */
- (double)tmbuf.tm_year + 1900));
+ (IV)tmbuf.tm_year + 1900));
}
}
else { /* list context */
/* Shared memory. */
/* Merged with some message passing. */
+/* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
+
PP(pp_shmwrite)
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
/* Semaphores. */
+/* also used for: pp_msgget() pp_shmget() */
+
PP(pp_semget)
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
#endif
}
+/* also used for: pp_msgctl() pp_shmctl() */
+
PP(pp_semctl)
{
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
/* Get system info. */
+/* also used for: pp_ghbyaddr() pp_ghbyname() */
+
PP(pp_ghostent)
{
#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
#endif
}
+/* also used for: pp_gnbyaddr() pp_gnbyname() */
+
PP(pp_gnetent)
{
#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
#endif
}
+
+/* also used for: pp_gpbyname() pp_gpbynumber() */
+
PP(pp_gprotoent)
{
#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
#endif
}
+
+/* also used for: pp_gsbyname() pp_gsbyport() */
+
PP(pp_gservent)
{
#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
#endif
}
+
+/* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
+
PP(pp_shostent)
{
dSP;
RETSETYES;
}
+
+/* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
+ * pp_eservent() pp_sgrent() pp_spwent() */
+
PP(pp_ehostent)
{
dSP;
RETPUSHYES;
}
+
+/* also used for: pp_gpwnam() pp_gpwuid() */
+
PP(pp_gpwent)
{
#ifdef HAS_PASSWD
#endif
}
+
+/* also used for: pp_ggrgid() pp_ggrnam() */
+
PP(pp_ggrent)
{
#ifdef HAS_GROUP
#define PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER \
assert(cv); assert(ckfun_p); assert(ckobj_p)
+PERL_CALLCONV SV * Perl_cv_name(pTHX_ CV *cv, SV *sv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CV_NAME \
+ assert(cv)
+
PERL_CALLCONV void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
#define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER \
assert(cv); assert(ckfun); assert(ckobj)
+PERL_CALLCONV void Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj, U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS \
+ assert(cv); assert(ckfun); assert(ckobj)
+
PERL_CALLCONV void Perl_cv_undef(pTHX_ CV* cv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_CV_UNDEF \
assert(cv)
+PERL_CALLCONV void Perl_cv_undef_flags(pTHX_ CV* cv, U32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CV_UNDEF_FLAGS \
+ assert(cv)
+
+PERL_CALLCONV GV * Perl_cvgv_from_hek(pTHX_ CV* cv)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CVGV_FROM_HEK \
+ assert(cv)
+
PERL_CALLCONV void Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_CVGV_SET \
#define PERL_ARGS_ASSERT_GROK_HEX \
assert(start); assert(len_p); assert(flags)
+PERL_CALLCONV int Perl_grok_infnan(const char** sp, const char *send)
+ __attribute__nonnull__(1)
+ __attribute__nonnull__(2);
+#define PERL_ARGS_ASSERT_GROK_INFNAN \
+ assert(sp); assert(send)
+
PERL_CALLCONV int Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_GROK_NUMBER \
#define PERL_ARGS_ASSERT_IS_UTF8_XIDFIRST \
assert(p)
+PERL_CALLCONV bool Perl_isinfnan(NV nv);
PERL_CALLCONV OP* Perl_jmaybe(pTHX_ OP *o)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_JMAYBE \
assert(buffer); assert(pat)
#endif
+#if !defined(USE_QUADMATH)
+# if defined(PERL_IN_NUMERIC_C)
+STATIC NV S_mulexp10(NV value, I32 exponent);
+# endif
+#endif
#if !defined(WIN32)
PERL_CALLCONV bool Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
__attribute__nonnull__(pTHX_1);
# endif
# if defined(PERL_IN_REGCOMP_C)
+STATIC const char * S_cntrl_to_mnemonic(const U8 c)
+ __attribute__pure__;
+
STATIC void S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV* widecharmap, AV *revcharmap, U32 depth)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_3);
#define PERL_ARGS_ASSERT_DUMPUNTIL \
assert(r); assert(start); assert(node); assert(sv)
-STATIC void S_put_byte(pTHX_ SV* sv, int c)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_PUT_BYTE \
- assert(sv)
-
-STATIC bool S_put_latin1_charclass_innards(pTHX_ SV* sv, char* bitmap)
+STATIC bool S_put_charclass_bitmap_innards(pTHX_ SV* sv, char* bitmap, SV** bitmap_invlist)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_PUT_LATIN1_CHARCLASS_INNARDS \
+#define PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS \
assert(sv); assert(bitmap)
-STATIC void S_put_range(pTHX_ SV* sv, UV start, UV end)
+STATIC void S_put_code_point(pTHX_ SV* sv, UV c)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_PUT_CODE_POINT \
+ assert(sv)
+
+STATIC void S_put_range(pTHX_ SV* sv, UV start, const UV end, const bool allow_literals)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_PUT_RANGE \
assert(sv)
#define PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA \
assert(gv)
+PERL_STATIC_INLINE HV* S_gv_stashpvn_internal(pTHX_ const char* name, U32 namelen, I32 flags)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL \
+ assert(name)
+
+PERL_STATIC_INLINE HV* S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char* name, U32 namelen, I32 flags);
STATIC void S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
assert(stash)
#endif
-#if defined(PERL_IN_NUMERIC_C)
-STATIC NV S_mulexp10(NV value, I32 exponent);
-#endif
#if defined(PERL_IN_OP_C)
PERL_STATIC_INLINE bool S_aassign_common_vars(pTHX_ OP* o);
STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
assert(o)
STATIC OP* S_gen_constant_list(pTHX_ OP* o);
-STATIC SV* S_gv_ename(pTHX_ GV *gv)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_GV_ENAME \
- assert(gv)
-
STATIC void S_inplace_aassign(pTHX_ OP* o)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_INPLACE_AASSIGN \
#define PERL_ARGS_ASSERT_PMTRANS \
assert(o); assert(expr); assert(repl)
-STATIC void S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv)
+STATIC bool S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv)
__attribute__nonnull__(pTHX_2)
__attribute__nonnull__(pTHX_3)
__attribute__nonnull__(pTHX_4);
#define PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV \
assert(o); assert(name)
-STATIC OP* S_too_few_arguments_sv(pTHX_ OP *o, SV* namesv, U32 flags)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV \
- assert(o); assert(namesv)
-
STATIC OP* S_too_many_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV \
assert(o); assert(name)
-STATIC OP* S_too_many_arguments_sv(pTHX_ OP *o, SV* namesv, U32 flags)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV \
- assert(o); assert(namesv)
-
#endif
#if defined(PERL_IN_OP_C) || defined(PERL_IN_SV_C)
PERL_CALLCONV void Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, SV * const *new_const_svp)
#endif
#if defined(PERL_IN_PP_CTL_C)
-STATIC SV ** S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags, bool lvalue)
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_3);
-#define PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE \
- assert(newsp); assert(sp); assert(mark)
-
STATIC PerlIO * S_check_type_and_open(pTHX_ SV *name)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
STATIC I32 S_dopoptowhen(pTHX_ I32 startingblock)
__attribute__warn_unused_result__;
+STATIC SV ** S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags, bool lvalue)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_LEAVE_COMMON \
+ assert(newsp); assert(sp); assert(mark)
+
STATIC PMOP* S_make_matcher(pTHX_ REGEXP* re)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_ADD_DATA \
assert(pRExC_state); assert(s)
+STATIC AV* S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_ADD_MULTI_MATCH \
+ assert(multi_string)
+
PERL_STATIC_INLINE void S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, regnode *node, I32 *flagp, STRLEN len, UV code_point, bool downgradable)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
#define PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR \
assert(invlist)
-STATIC bool S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** nodep, UV *valuep, I32 *flagp, U32 depth, bool in_char_class, const bool strict)
+STATIC STRLEN S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** nodep, UV *valuep, I32 *flagp, U32 depth, SV** substitute_parse)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_4);
#define PERL_ARGS_ASSERT_GROK_BSLASH_N \
#endif
#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C)
-PERL_CALLCONV SV* Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog, const struct regnode *node, bool doinit, SV **listsvp, SV **lonly_utf8_locale)
+PERL_CALLCONV SV* Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog, const struct regnode *node, bool doinit, SV **listsvp, SV **lonly_utf8_locale, SV *exclude_list)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA \
assert(node)
#define PERL_ARGS_ASSERT_INCLINE \
assert(s)
-STATIC int S_intuit_method(pTHX_ char *s, GV *gv, CV *cv)
+STATIC int S_intuit_method(pTHX_ char *s, SV *ioname, CV *cv)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_INTUIT_METHOD \
assert(s)
assert(vbuf)
#endif
+#if defined(USE_QUADMATH)
+PERL_CALLCONV bool Perl_quadmath_format_needed(const char* format)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED \
+ assert(format)
+
+PERL_CALLCONV const char* Perl_quadmath_format_single(const char* format)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE \
+ assert(format)
+
+#endif
#if defined(WIN32)
PERL_CALLCONV char* Perl_my_setlocale(pTHX_ int category, const char* locale)
__attribute__pure__;
regnode_ssc *start_class;
} scan_data_t;
-/* The below is perhaps overboard, but this allows us to save a test at the
- * expense of a mask. This is because on both EBCDIC and ASCII machines, 'A'
- * and 'a' differ by a single bit; the same with the upper and lower case of
- * all other ASCII-range alphabetics. On ASCII platforms, they are 32 apart;
- * on EBCDIC, they are 64. This uses an exclusive 'or' to find that bit and
- * then inverts it to form a mask, with just a single 0, in the bit position
- * where the upper- and lowercase differ. XXX There are about 40 other
- * instances in the Perl core where this micro-optimization could be used.
- * Should decide if maintenance cost is worse, before changing those
- *
- * Returns a boolean as to whether or not 'v' is either a lowercase or
- * uppercase instance of 'c', where 'c' is in [A-Za-z]. If 'c' is a
- * compile-time constant, the generated code is better than some optimizing
- * compilers figure out, amounting to a mask and test. The results are
- * meaningless if 'c' is not one of [A-Za-z] */
-#define isARG2_lower_or_UPPER_ARG1(c, v) \
- (((v) & ~('A' ^ 'a')) == ((c) & ~('A' ^ 'a')))
-
/*
* Forward declarations for pregcomp()'s friends.
*/
REPORT_LOCATION_ARGS(offset)); \
} STMT_END
+/* These have asserts in them because of [perl #122671] Many warnings in
+ * regcomp.c can occur twice. If they get output in pass1 and later in that
+ * pass, the pattern has to be converted to UTF-8 and the pass restarted, they
+ * would get output again. So they should be output in pass2, and these
+ * asserts make sure new warnings follow that paradigm. */
/* m is not necessarily a "literal string", in this macro */
#define reg_warn_non_literal_string(loc, m) STMT_START { \
const IV offset = loc - RExC_precomp; \
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION, \
+ __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION, \
m, REPORT_LOCATION_ARGS(offset)); \
} STMT_END
#define ckWARNreg(loc,m) STMT_START { \
const IV offset = loc - RExC_precomp; \
- Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
+ __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
REPORT_LOCATION_ARGS(offset)); \
} STMT_END
#define vWARN_dep(loc, m) STMT_START { \
const IV offset = loc - RExC_precomp; \
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION, \
+ __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION, \
REPORT_LOCATION_ARGS(offset)); \
} STMT_END
#define ckWARNdep(loc,m) STMT_START { \
const IV offset = loc - RExC_precomp; \
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), \
+ __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), \
m REPORT_LOCATION, \
REPORT_LOCATION_ARGS(offset)); \
} STMT_END
#define ckWARNregdep(loc,m) STMT_START { \
const IV offset = loc - RExC_precomp; \
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
+ __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
m REPORT_LOCATION, \
REPORT_LOCATION_ARGS(offset)); \
} STMT_END
#define ckWARN2reg_d(loc,m, a1) STMT_START { \
const IV offset = loc - RExC_precomp; \
- Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP), \
+ __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP), \
m REPORT_LOCATION, \
a1, REPORT_LOCATION_ARGS(offset)); \
} STMT_END
#define ckWARN2reg(loc, m, a1) STMT_START { \
const IV offset = loc - RExC_precomp; \
- Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
+ __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
a1, REPORT_LOCATION_ARGS(offset)); \
} STMT_END
#define vWARN3(loc, m, a1, a2) STMT_START { \
const IV offset = loc - RExC_precomp; \
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
+ __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
a1, a2, REPORT_LOCATION_ARGS(offset)); \
} STMT_END
#define ckWARN3reg(loc, m, a1, a2) STMT_START { \
const IV offset = loc - RExC_precomp; \
- Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
+ __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
a1, a2, REPORT_LOCATION_ARGS(offset)); \
} STMT_END
#define vWARN4(loc, m, a1, a2, a3) STMT_START { \
const IV offset = loc - RExC_precomp; \
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
+ __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
a1, a2, a3, REPORT_LOCATION_ARGS(offset)); \
} STMT_END
#define ckWARN4reg(loc, m, a1, a2, a3) STMT_START { \
const IV offset = loc - RExC_precomp; \
- Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
+ __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
a1, a2, a3, REPORT_LOCATION_ARGS(offset)); \
} STMT_END
#define vWARN5(loc, m, a1, a2, a3, a4) STMT_START { \
const IV offset = loc - RExC_precomp; \
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
+ __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
a1, a2, a3, a4, REPORT_LOCATION_ARGS(offset)); \
} STMT_END
PerlIO_printf(Perl_debug_log,"\n"); \
});
+#ifdef DEBUGGING
+
+/* is c a control character for which we have a mnemonic? */
+#define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
+
+STATIC const char *
+S_cntrl_to_mnemonic(const U8 c)
+{
+ /* Returns the mnemonic string that represents character 'c', if one
+ * exists; NULL otherwise. The only ones that exist for the purposes of
+ * this routine are a few control characters */
+
+ switch (c) {
+ case '\a': return "\\a";
+ case '\b': return "\\b";
+ case ESC_NATIVE: return "\\e";
+ case '\f': return "\\f";
+ case '\n': return "\\n";
+ case '\r': return "\\r";
+ case '\t': return "\\t";
+ }
+
+ return NULL;
+}
+
+#endif
+
/* Mark that we cannot extend a found fixed substring at this point.
Update the longest found anchored substring and the longest found
floating substrings if needed. */
ssc->invlist = sv_2mortal(_new_invlist(2)); /* mortalize so won't leak */
_append_range_to_invlist(ssc->invlist, 0, UV_MAX);
- ANYOF_FLAGS(ssc) |= ANYOF_EMPTY_STRING; /* Plus match empty string */
+ ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING; /* Plus matches empty */
}
STATIC int
assert(is_ANYOF_SYNTHETIC(ssc));
- if (! (ANYOF_FLAGS(ssc) & ANYOF_EMPTY_STRING)) {
+ if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
return FALSE;
}
Zero(ssc, 1, regnode_ssc);
set_ANYOF_SYNTHETIC(ssc);
- ARG_SET(ssc, ANYOF_NONBITMAP_EMPTY);
+ ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
ssc_anything(ssc);
/* If any portion of the regex is to operate under locale rules,
PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
/* Look at the data structure created by S_set_ANYOF_arg() */
- if (n != ANYOF_NONBITMAP_EMPTY) {
+ if (n != ANYOF_ONLY_HAS_BITMAP) {
SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
AV * const av = MUTABLE_AV(SvRV(rv));
SV **const ary = AvARRAY(av);
}
}
- /* An ANYOF node contains a bitmap for the first 256 code points, and an
- * inversion list for the others, but if there are code points that should
- * match only conditionally on the target string being UTF-8, those are
- * placed in the inversion list, and not the bitmap. Since there are
- * circumstances under which they could match, they are included in the
- * SSC. But if the ANYOF node is to be inverted, we have to exclude them
- * here, so that when we invert below, the end result actually does include
- * them. (Think about "\xe0" =~ /[^\xc0]/di;). We have to do this here
- * before we add the unconditionally matched code points */
+ /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
+ * code points, and an inversion list for the others, but if there are code
+ * points that should match only conditionally on the target string being
+ * UTF-8, those are placed in the inversion list, and not the bitmap.
+ * Since there are circumstances under which they could match, they are
+ * included in the SSC. But if the ANYOF node is to be inverted, we have
+ * to exclude them here, so that when we invert below, the end result
+ * actually does include them. (Think about "\xe0" =~ /[^\xc0]/di;). We
+ * have to do this here before we add the unconditionally matched code
+ * points */
if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
_invlist_intersection_complement_2nd(invlist,
PL_UpperLatin1,
}
/* Add in the points from the bit map */
- for (i = 0; i < 256; i++) {
+ for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
if (ANYOF_BITMAP_TEST(node, i)) {
invlist = add_cp_to_invlist(invlist, i);
new_node_has_latin1 = TRUE;
/* If this can match all upper Latin1 code points, have to add them
* as well */
- if (ANYOF_FLAGS(node) & ANYOF_NON_UTF8_NON_ASCII_ALL) {
+ if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII) {
_invlist_union(invlist, PL_UpperLatin1, &invlist);
}
/* Similarly for these */
- if (ANYOF_FLAGS(node) & ANYOF_ABOVE_LATIN1_ALL) {
- invlist = _add_range_to_invlist(invlist, 256, UV_MAX);
+ if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
+ _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
}
if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
#define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
/* 'AND' a given class with another one. Can create false positives. 'ssc'
- * should not be inverted. 'and_with->flags & ANYOF_POSIXL' should be 0 if
- * 'and_with' is a regnode_charclass instead of a regnode_ssc. */
+ * should not be inverted. 'and_with->flags & ANYOF_MATCHES_POSIXL' should be
+ * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
STATIC void
S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
/* If either P1 or P2 is empty, the intersection will be also; can skip
* the loop */
- if (! (ANYOF_FLAGS(and_with) & ANYOF_POSIXL)) {
+ if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) {
ANYOF_POSIXL_ZERO(ssc);
}
else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
else {
ssc->invlist = anded_cp_list;
ANYOF_POSIXL_ZERO(ssc);
- if (ANYOF_FLAGS(and_with) & ANYOF_POSIXL) {
+ if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
}
}
}
else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
- || (ANYOF_FLAGS(and_with) & ANYOF_POSIXL))
+ || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL))
{
/* One or the other of P1, P2 is non-empty. */
- if (ANYOF_FLAGS(and_with) & ANYOF_POSIXL) {
+ if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
}
ssc_union(ssc, anded_cp_list, FALSE);
{
/* We ignore P2, leaving P1 going forward */
} /* else Not inverted */
- else if (ANYOF_FLAGS(or_with) & ANYOF_POSIXL) {
+ else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) {
ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
unsigned int i;
{
/* The inversion list in the SSC is marked mortal; now we need a more
* permanent copy, which is stored the same way that is done in a regular
- * ANYOF node, with the first 256 code points in a bit map */
+ * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
+ * map */
SV* invlist = invlist_clone(ssc->invlist);
assert(is_ANYOF_SYNTHETIC(ssc));
/* The code in this file assumes that all but these flags aren't relevant
- * to the SSC, except ANYOF_EMPTY_STRING, which should be cleared by the
- * time we reach here */
+ * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
+ * by the time we reach here */
assert(! (ANYOF_FLAGS(ssc) & ~ANYOF_COMMON_FLAGS));
populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
ssc->invlist = NULL;
if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
- ANYOF_FLAGS(ssc) |= ANYOF_POSIXL;
+ ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
}
assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
}
if (len == 2
- && isARG2_lower_or_UPPER_ARG1('s', *s)
- && isARG2_lower_or_UPPER_ARG1('s', *(s+1)))
+ && isALPHA_FOLD_EQ(*s, 's')
+ && isALPHA_FOLD_EQ(*(s+1), 's'))
{
/* EXACTF nodes need to know that the minimum length
* can't match null string */
if (flags & SCF_DO_STCLASS_AND) {
ssc_cp_and(data->start_class, uc);
- ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING;
+ ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
ssc_clear_locale(data->start_class);
}
else if (flags & SCF_DO_STCLASS_OR) {
ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
/* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
- ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING;
+ ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
}
flags &= ~SCF_DO_STCLASS;
}
}
}
if (flags & SCF_DO_STCLASS_AND) {
- ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING;
+ ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
ANYOF_POSIXL_ZERO(data->start_class);
ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
}
ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
/* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
- ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING;
+ ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
}
flags &= ~SCF_DO_STCLASS;
SvREFCNT_dec(EXACTF_invlist);
flags &= ~SCF_DO_STCLASS_AND;
StructCopy(&this_class, data->start_class, regnode_ssc);
flags |= SCF_DO_STCLASS_OR;
- ANYOF_FLAGS(data->start_class) |= ANYOF_EMPTY_STRING;
+ ANYOF_FLAGS(data->start_class)
+ |= SSC_MATCHES_EMPTY_STRING;
}
} else { /* Non-zero len */
if (flags & SCF_DO_STCLASS_OR) {
ssc_intersection(data->start_class,
PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
ssc_clear_locale(data->start_class);
- ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING;
+ ANYOF_FLAGS(data->start_class)
+ &= ~SSC_MATCHES_EMPTY_STRING;
}
else if (flags & SCF_DO_STCLASS_OR) {
ssc_union(data->start_class,
/* See commit msg for
* 749e076fceedeb708a624933726e7989f2302f6a */
- ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING;
+ ANYOF_FLAGS(data->start_class)
+ &= ~SSC_MATCHES_EMPTY_STRING;
}
flags &= ~SCF_DO_STCLASS;
}
U8 namedclass;
/* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
- ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING;
+ ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
/* Some of the logic below assumes that switching
locale on will only add false positives. */
* assertions are zero-length, so can match an EMPTY
* string */
ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
- ANYOF_FLAGS(data->start_class) |= ANYOF_EMPTY_STRING;
+ ANYOF_FLAGS(data->start_class)
+ |= SSC_MATCHES_EMPTY_STRING;
}
}
}
if (f & SCF_DO_STCLASS_AND) {
ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
- ANYOF_FLAGS(data->start_class) |= ANYOF_EMPTY_STRING;
+ ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
}
if (data) {
if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
char **pat_p, STRLEN *plen_p, int num_code_blocks)
{
U8 *const src = (U8*)*pat_p;
- U8 *dst;
+ U8 *dst, *d;
int n=0;
- STRLEN s = 0, d = 0;
+ STRLEN s = 0;
bool do_end = 0;
GET_RE_DEBUG_FLAGS_DECL;
"UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
Newx(dst, *plen_p * 2 + 1, U8);
+ d = dst;
while (s < *plen_p) {
- if (NATIVE_BYTE_IS_INVARIANT(src[s]))
- dst[d] = src[s];
- else {
- dst[d++] = UTF8_EIGHT_BIT_HI(src[s]);
- dst[d] = UTF8_EIGHT_BIT_LO(src[s]);
- }
+ append_utf8_from_native_byte(src[s], &d);
if (n < num_code_blocks) {
if (!do_end && pRExC_state->code_blocks[n].start == s) {
- pRExC_state->code_blocks[n].start = d;
- assert(dst[d] == '(');
+ pRExC_state->code_blocks[n].start = d - dst - 1;
+ assert(*(d - 1) == '(');
do_end = 1;
}
else if (do_end && pRExC_state->code_blocks[n].end == s) {
- pRExC_state->code_blocks[n].end = d;
- assert(dst[d] == ')');
+ pRExC_state->code_blocks[n].end = d - dst - 1;
+ assert(*(d - 1) == ')');
do_end = 0;
n++;
}
}
s++;
- d++;
}
- dst[d] = '\0';
- *plen_p = d;
+ *d = '\0';
+ *plen_p = d - dst;
*pat_p = (char*) dst;
SAVEFREEPV(*pat_p);
RExC_orig_utf8 = RExC_utf8 = 1;
ENTER;
SAVETMPS;
- save_re_context();
PUSHSTACKi(PERLSI_REQUIRE);
/* G_RE_REPARSING causes the toker to collapse \\ into \ when
* parsing qr''; normally only q'' does this. It also alters
PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist);
PL_HasMultiCharFold =
_new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist);
+
+ /* This is calculated here, because the Perl program that generates the
+ * static global ones doesn't currently have access to
+ * NUM_ANYOF_CODE_POINTS */
+ PL_InBitmap = _new_invlist(2);
+ PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
+ NUM_ANYOF_CODE_POINTS - 1);
}
#endif
else if (PL_regkind[OP(first)] == BOL) {
r->intflags |= (OP(first) == MBOL
? PREGf_ANCH_MBOL
- : (OP(first) == SBOL
- ? PREGf_ANCH_SBOL
- : PREGf_ANCH_BOL));
+ : PREGf_ANCH_SBOL);
first = NEXTOPER(first);
goto again;
}
if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
&& stclass_flag
- && ! (ANYOF_FLAGS(data.start_class) & ANYOF_EMPTY_STRING)
+ && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
&& !ssc_is_anything(data.start_class))
{
const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
= r->float_substr = r->float_utf8 = NULL;
- if (! (ANYOF_FLAGS(data.start_class) & ANYOF_EMPTY_STRING)
+ if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
&& ! ssc_is_anything(data.start_class))
{
const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
/* Guard against an embedded (?=) or (?<=) with a longer minlen than
the "real" pattern. */
DEBUG_OPTIMISE_r({
- PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf" maxlen:%ld\n",
- (IV)minlen, (IV)r->minlen, RExC_maxlen);
+ PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf" maxlen:%"IVdf"\n",
+ (IV)minlen, (IV)r->minlen, (IV)RExC_maxlen);
});
r->minlenret = minlen;
if (r->minlen < minlen)
if (PL_regkind[fop] == NOTHING && nop == END)
r->extflags |= RXf_NULL;
- else if (PL_regkind[fop] == BOL && nop == END)
+ else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
+ /* when fop is SBOL first->flags will be true only when it was
+ * produced by parsing /\A/, and not when parsing /^/. This is
+ * very important for the split code as there we want to
+ * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
+ * See rt #122761 for more details. -- Yves */
r->extflags |= RXf_START_ONLY;
else if (fop == PLUS
&& PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
/*NOTREACHED*/
case ONCE_PAT_MOD: /* 'o' */
case GLOBAL_PAT_MOD: /* 'g' */
- if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
+ if (PASS2 && ckWARN(WARN_REGEXP)) {
const I32 wflagbit = *RExC_parse == 'o'
? WASTED_O
: WASTED_G;
break;
case CONTINUE_PAT_MOD: /* 'c' */
- if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
+ if (PASS2 && ckWARN(WARN_REGEXP)) {
if (! (wastedflags & WASTED_C) ) {
wastedflags |= WASTED_GC;
/* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
break;
case KEEPCOPY_PAT_MOD: /* 'p' */
if (flagsp == &negflags) {
- if (SIZE_ONLY)
+ if (PASS2)
ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
} else {
*flagsp |= RXf_PMf_KEEPCOPY;
if (max < min) { /* If can't match, warn and optimize to fail
unconditionally */
if (SIZE_ONLY) {
- ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
/* We can't back off the size because we have to reserve
* enough space for all the things we are about to throw
RExC_size = PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
}
else {
+ ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
RExC_emit = orig_emit;
}
ret = reg_node(pRExC_state, OPFAIL);
&& RExC_parse < RExC_end
&& (*RExC_parse == '?' || *RExC_parse == '+'))
{
- if (SIZE_ONLY) {
+ if (PASS2) {
ckWARN2reg(RExC_parse + 1,
"Useless use of greediness modifier '%c'",
*RExC_parse);
return(ret);
}
-STATIC bool
+STATIC STRLEN
S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p,
- UV *valuep, I32 *flagp, U32 depth, bool in_char_class,
- const bool strict /* Apply stricter parsing rules? */
+ UV *valuep, I32 *flagp, U32 depth, SV** substitute_parse
)
{
and needs to handle the rest. RExC_parse is expected to point at the first
char following the N at the time of the call. On successful return,
RExC_parse has been updated to point to just after the sequence identified
- by this routine, and <*flagp> has been updated.
-
- The \N may be inside (indicated by the boolean <in_char_class>) or outside a
- character class.
-
- \N may begin either a named sequence, or if outside a character class, mean
- to match a non-newline. For non single-quoted regexes, the tokenizer has
- attempted to decide which, and in the case of a named sequence, converted it
+ by this routine, <*flagp> has been updated, and the non-NULL input pointers
+ have been set appropriately.
+
+ The typical case for this is \N{some character name}. This is usually
+ called while parsing the input, filling in or ready to fill in an EXACTish
+ node, and the code point for the character should be returned, so that it
+ can be added to the node, and parsing continued with the next input
+ character. But it may be that instead of a single character the \N{}
+ expands to more than one, a named sequence. In this case any following
+ quantifier applies to the whole sequence, and it is easier, given the code
+ structure that calls this, to handle it from a different area of the code.
+ For this reason, the input parameters can be set so that it returns valid
+ only on one or the other of these cases.
+
+ Another possibility is for the input to be an empty \N{}, which for
+ backwards compatibility we accept, but generate a NOTHING node which should
+ later get optimized out. This is handled from the area of code which can
+ handle a named sequence, so if called with the parameters for the other, it
+ fails.
+
+ Still another possibility is for the \N to mean [^\n], and not a single
+ character or explicit sequence at all. This is determined by context.
+ Again, this is handled from the area of code which can handle a named
+ sequence, so if called with the parameters for the other, it also fails.
+
+ And the final possibility is for the \N to be called from within a bracketed
+ character class. In this case the [^\n] meaning makes no sense, and so is
+ an error. Other anomalous situations are left to the calling code to handle.
+
+ For non-single-quoted regexes, the tokenizer has attempted to decide which
+ of the above applies, and in the case of a named sequence, has converted it
into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
where c1... are the characters in the sequence. For single-quoted regexes,
the tokenizer passes the \N sequence through unchanged; this code will not
attempt to determine this nor expand those, instead raising a syntax error.
The net effect is that if the beginning of the passed-in pattern isn't '{U+'
or there is no '}', it signals that this \N occurrence means to match a
- non-newline.
+ non-newline. (This mostly was done because of [perl #56444].)
- Only the \N{U+...} form should occur in a character class, for the same
- reason that '.' inside a character class means to just match a period: it
- just doesn't make sense.
+ The API is somewhat convoluted due to historical and the above reasons.
The function raises an error (via vFAIL), and doesn't return for various
- syntax errors. Otherwise it returns TRUE and sets <node_p> or <valuep> on
- success; it returns FALSE otherwise. Returns FALSE, setting *flagp to
- RESTART_UTF8 if the sizing scan needs to be restarted. Such a restart is
- only possible if node_p is non-NULL.
-
+ syntax errors. For other failures, it returns (STRLEN) -1. For successes,
+ it returns a count of how many characters were accounted for by it. (This
+ can be 0 for \N{}; 1 for it meaning [^\n]; and otherwise the number of code
+ points in the sequence. It sets <node_p>, <valuep>, and/or
+ <substitute_parse> on success.
If <valuep> is non-null, it means the caller can accept an input sequence
- consisting of a just a single code point; <*valuep> is set to that value
- if the input is such.
-
- If <node_p> is non-null it signifies that the caller can accept any other
- legal sequence (i.e., one that isn't just a single code point). <*node_p>
- is set as follows:
- 1) \N means not-a-NL: points to a newly created REG_ANY node;
- 2) \N{}: points to a new NOTHING node;
+ consisting of a just a single code point; <*valuep> is set to the value
+ of the only or first code point in the input.
+
+ If <substitute_parse> is non-null, it means the caller can accept an input
+ sequence consisting of one or more code points; <*substitute_parse> is a
+ newly created mortal SV* in this case, containing \x{} escapes representing
+ those code points.
+
+ Both <valuep> and <substitute_parse> can be non-NULL.
+
+ If <node_p> is non-null, <substitute_parse> must be NULL. This signifies
+ that the caller can accept any legal sequence other than a single code
+ point. To wit, <*node_p> is set as follows:
+ 1) \N means not-a-NL: points to a newly created REG_ANY node; return is 1
+ 2) \N{}: points to a new NOTHING node; return is 0
3) otherwise: points to a new EXACT node containing the resolved
- string.
- Note that FALSE is returned for single code point sequences if <valuep> is
- null.
+ string; return is the number of code points in the
+ string. This will never be 1.
+ Note that failure is returned for single code point sequences if <valuep> is
+ null and <node_p> is not.
*/
char * endbrace; /* '}' following the name */
stream */
bool has_multiple_chars; /* true if the input stream contains a sequence of
more than one character */
+ bool in_char_class = substitute_parse != NULL;
+ STRLEN count = 0; /* Number of characters in this sequence */
GET_RE_DEBUG_FLAGS_DECL;
GET_RE_DEBUG_FLAGS;
assert(cBOOL(node_p) ^ cBOOL(valuep)); /* Exactly one should be set */
+ assert(! (node_p && substitute_parse)); /* At most 1 should be set */
/* The [^\n] meaning of \N ignores spaces and comments under the /x
* modifier. The other meaning does not, so use a temporary until we find
if (in_char_class) {
vFAIL("\\N in a character class must be a named character: \\N{...}");
}
- return FALSE;
+ return (STRLEN) -1;
}
RExC_parse--; /* Need to back off so nextchar() doesn't skip the
current char */
*flagp |= HASWIDTH|SIMPLE;
RExC_naughty++;
Set_Node_Length(*node_p, 1); /* MJD */
- return TRUE;
+ return 1;
}
/* Here, we have decided it should be a named character or sequence */
}
if (endbrace == RExC_parse) { /* empty: \N{} */
- bool ret = TRUE;
if (node_p) {
*node_p = reg_node(pRExC_state,NOTHING);
}
- else if (in_char_class) {
- if (SIZE_ONLY && in_char_class) {
- if (strict) {
- RExC_parse++; /* Position after the "}" */
- vFAIL("Zero length \\N{}");
- }
- else {
- ckWARNreg(RExC_parse,
- "Ignoring zero length \\N{} in character class");
- }
- }
- ret = FALSE;
- }
- else {
- return FALSE;
+ else if (! in_char_class) {
+ return (STRLEN) -1;
}
nextchar(pRExC_state);
- return ret;
+ return 0;
}
RExC_uni_semantics = 1; /* Unicode named chars imply Unicode semantics */
* point, and is terminated by the brace */
has_multiple_chars = (endchar < endbrace);
- if (valuep && (! has_multiple_chars || in_char_class)) {
- /* We only pay attention to the first char of
- multichar strings being returned in char classes. I kinda wonder
- if this makes sense as it does change the behaviour
- from earlier versions, OTOH that behaviour was broken
- as well. XXX Solution is to recharacterize as
- [rest-of-class]|multi1|multi2... */
-
+ /* We get the first code point if we want it, and either there is only one,
+ * or we can accept both cases of one and more than one */
+ if (valuep && (substitute_parse || ! has_multiple_chars)) {
STRLEN length_of_hex = (STRLEN)(endchar - RExC_parse);
I32 grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
- | PERL_SCAN_DISALLOW_PREFIX
- | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
+ | PERL_SCAN_DISALLOW_PREFIX
+
+ /* No errors in the first pass (See [perl
+ * #122671].) We let the code below find the
+ * errors when there are multiple chars. */
+ | ((SIZE_ONLY || has_multiple_chars)
+ ? PERL_SCAN_SILENT_ILLDIGIT
+ : 0);
*valuep = grok_hex(RExC_parse, &length_of_hex, &grok_hex_flags, NULL);
/* The tokenizer should have guaranteed validity, but it's possible to
- * bypass it by using single quoting, so check */
- if (length_of_hex == 0
- || length_of_hex != (STRLEN)(endchar - RExC_parse) )
- {
- RExC_parse += length_of_hex; /* Includes all the valid */
- RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */
- ? UTF8SKIP(RExC_parse)
- : 1;
- /* Guard against malformed utf8 */
- if (RExC_parse >= endchar) {
- RExC_parse = endchar;
+ * bypass it by using single quoting, so check. Don't do the check
+ * here when there are multiple chars; we do it below anyway. */
+ if (! has_multiple_chars) {
+ if (length_of_hex == 0
+ || length_of_hex != (STRLEN)(endchar - RExC_parse) )
+ {
+ RExC_parse += length_of_hex; /* Includes all the valid */
+ RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */
+ ? UTF8SKIP(RExC_parse)
+ : 1;
+ /* Guard against malformed utf8 */
+ if (RExC_parse >= endchar) {
+ RExC_parse = endchar;
+ }
+ vFAIL("Invalid hexadecimal number in \\N{U+...}");
}
- vFAIL("Invalid hexadecimal number in \\N{U+...}");
- }
- if (in_char_class && has_multiple_chars) {
- if (strict) {
- RExC_parse = endbrace;
- vFAIL("\\N{} in character class restricted to one character");
- }
- else {
- ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
- }
+ RExC_parse = endbrace + 1;
+ return 1;
}
-
- RExC_parse = endbrace + 1;
}
- else if (! node_p || ! has_multiple_chars) {
- /* Here, the input is legal, but not according to the caller's
- * options. We fail without advancing the parse, so that the
- * caller can try again */
+ /* Here, we should have already handled the case where a single character
+ * is expected and found. So it is a failure if we aren't expecting
+ * multiple chars and got them; or didn't get them but wanted them. We
+ * fail without advancing the parse, so that the caller can try again with
+ * different acceptance criteria */
+ if ((! node_p && ! substitute_parse) || ! has_multiple_chars) {
RExC_parse = p;
- return FALSE;
+ return (STRLEN) -1;
}
- else {
+
+ {
/* What is done here is to convert this to a sub-pattern of the form
- * (?:\x{char1}\x{char2}...)
- * and then call reg recursively. That way, it retains its atomicness,
- * while not having to worry about special handling that some code
- * points may have. toke.c has converted the original Unicode values
- * to native, so that we can just pass on the hex values unchanged. We
- * do have to set a flag to keep recoding from happening in the
- * recursion */
-
- SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
+ * \x{char1}\x{char2}...
+ * and then either return it in <*substitute_parse> if non-null; or
+ * call reg recursively to parse it (enclosing in "(?: ... )" ). That
+ * way, it retains its atomicness, while not having to worry about
+ * special handling that some code points may have. toke.c has
+ * converted the original Unicode values to native, so that we can just
+ * pass on the hex values unchanged. We do have to set a flag to keep
+ * recoding from happening in the recursion */
+
+ SV * dummy = NULL;
STRLEN len;
char *orig_end = RExC_end;
I32 flags;
+ if (substitute_parse) {
+ *substitute_parse = newSVpvs("");
+ }
+ else {
+ substitute_parse = &dummy;
+ *substitute_parse = newSVpvs("?:");
+ }
+ *substitute_parse = sv_2mortal(*substitute_parse);
+
while (RExC_parse < endbrace) {
/* Convert to notation the rest of the code understands */
- sv_catpv(substitute_parse, "\\x{");
- sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
- sv_catpv(substitute_parse, "}");
+ sv_catpv(*substitute_parse, "\\x{");
+ sv_catpvn(*substitute_parse, RExC_parse, endchar - RExC_parse);
+ sv_catpv(*substitute_parse, "}");
/* Point to the beginning of the next character in the sequence. */
RExC_parse = endchar + 1;
endchar = RExC_parse + strcspn(RExC_parse, ".}");
+
+ count++;
}
- sv_catpv(substitute_parse, ")");
+ if (! in_char_class) {
+ sv_catpv(*substitute_parse, ")");
+ }
- RExC_parse = SvPV(substitute_parse, len);
+ RExC_parse = SvPV(*substitute_parse, len);
/* Don't allow empty number */
- if (len < 8) {
+ if (len < (STRLEN) ((substitute_parse) ? 6 : 8)) {
+ RExC_parse = endbrace;
vFAIL("Invalid hexadecimal number in \\N{U+...}");
}
RExC_end = RExC_parse + len;
/* The values are Unicode, and therefore not subject to recoding */
RExC_override_recoding = 1;
- if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
- if (flags & RESTART_UTF8) {
- *flagp = RESTART_UTF8;
- return FALSE;
+ if (node_p) {
+ if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
+ if (flags & RESTART_UTF8) {
+ *flagp = RESTART_UTF8;
+ return (STRLEN) -1;
+ }
+ FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#"UVxf"",
+ (UV) flags);
}
- FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#"UVxf"",
- (UV) flags);
+ *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
}
- *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
RExC_parse = endbrace;
RExC_end = orig_end;
nextchar(pRExC_state);
}
- return TRUE;
+ return count;
}
if (LOC || ! FOLD) { /* /l defers folding until runtime */
*character = (U8) code_point;
}
- else { /* Here is /i and not /l (toFOLD() is defined on just
+ else { /* Here is /i and not /l. (toFOLD() is defined on just
ASCII, which isn't the same thing as INVARIANT on
EBCDIC, but it works there, as the extra invariants
fold to themselves) */
*character = toFOLD((U8) code_point);
- if (downgradable
- && *character == code_point
- && ! HAS_NONLATIN1_FOLD_CLOSURE(code_point))
- {
+
+ /* We can downgrade to an EXACT node if this character
+ * isn't a folding one. Note that this assumes that
+ * nothing above Latin1 folds to some other invariant than
+ * one of these alphabetics; otherwise we would also have
+ * to check:
+ * && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
+ * || ASCII_FOLD_RESTRICTED))
+ */
+ if (downgradable && PL_fold[code_point] == code_point) {
OP(node) = EXACT;
}
}
? FOLD_FLAGS_NOMIX_ASCII
: 0));
if (downgradable
- && folded == code_point
+ && folded == code_point /* This quickly rules out many
+ cases, avoiding the
+ _invlist_contains_cp() overhead
+ for those. */
&& ! _invlist_contains_cp(PL_utf8_foldable, code_point))
{
OP(node) = EXACT;
nextchar(pRExC_state);
if (RExC_flags & RXf_PMf_MULTILINE)
ret = reg_node(pRExC_state, MBOL);
- else if (RExC_flags & RXf_PMf_SINGLELINE)
- ret = reg_node(pRExC_state, SBOL);
else
- ret = reg_node(pRExC_state, BOL);
+ ret = reg_node(pRExC_state, SBOL);
Set_Node_Length(ret, 1); /* MJD */
break;
case '$':
RExC_seen_zerolen++;
if (RExC_flags & RXf_PMf_MULTILINE)
ret = reg_node(pRExC_state, MEOL);
- else if (RExC_flags & RXf_PMf_SINGLELINE)
- ret = reg_node(pRExC_state, SEOL);
else
- ret = reg_node(pRExC_state, EOL);
+ ret = reg_node(pRExC_state, SEOL);
Set_Node_Length(ret, 1); /* MJD */
break;
case '.':
case 'A':
RExC_seen_zerolen++;
ret = reg_node(pRExC_state, SBOL);
+ /* SBOL is shared with /^/ so we set the flags so we can tell
+ * /\A/ from /^/ in split. We check ret because first pass we
+ * have no regop struct to set the flags on. */
+ if (PASS2)
+ ret->flags = 1;
*flagp |= SIMPLE;
goto finish_meta_pat;
case 'G':
ret = reg_node(pRExC_state, CANY);
RExC_seen |= REG_CANY_SEEN;
*flagp |= HASWIDTH|SIMPLE;
- if (SIZE_ONLY) {
+ if (PASS2) {
ckWARNdep(RExC_parse+1, "\\C is deprecated");
}
goto finish_meta_pat;
ret = reg_node(pRExC_state, op);
FLAGS(ret) = get_regex_charset(RExC_flags);
*flagp |= SIMPLE;
- if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
+ if ((U8) *(RExC_parse + 1) == '{') {
/* diag_listed_as: Use "%s" instead of "%s" */
vFAIL("Use \"\\b\\{\" instead of \"\\b{\"");
}
ret = reg_node(pRExC_state, op);
FLAGS(ret) = get_regex_charset(RExC_flags);
*flagp |= SIMPLE;
- if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
+ if ((U8) *(RExC_parse + 1) == '{') {
/* diag_listed_as: Use "%s" instead of "%s" */
vFAIL("Use \"\\B\\{\" instead of \"\\B{\"");
}
* special treatment for quantifiers is not needed for such single
* character sequences */
++RExC_parse;
- if (! grok_bslash_N(pRExC_state, &ret, NULL, flagp, depth, FALSE,
- FALSE /* not strict */ )) {
+ if ((STRLEN) -1 == grok_bslash_N(pRExC_state, &ret, NULL, flagp,
+ depth, FALSE))
+ {
if (*flagp & RESTART_UTF8)
return NULL;
RExC_parse--;
* point sequence. Handle those in the switch() above
* */
RExC_parse = p + 1;
- if (! grok_bslash_N(pRExC_state, NULL, &ender,
- flagp, depth, FALSE,
- FALSE /* not strict */ ))
- {
+ if ((STRLEN) -1 == grok_bslash_N(pRExC_state, NULL,
+ &ender,
+ flagp,
+ depth,
+ FALSE
+ )) {
if (*flagp & RESTART_UTF8)
FAIL("panic: grok_bslash_N set RESTART_UTF8");
RExC_parse = p = oldp;
p++;
break;
case 'e':
- ender = ASCII_TO_NATIVE('\033');
+ ender = ESC_NATIVE;
p++;
break;
case 'a':
- ender = '\a';
+ ender = '\a';
p++;
break;
case 'o':
bool valid = grok_bslash_o(&p,
&result,
&error_msg,
- TRUE, /* out warnings */
+ PASS2, /* out warnings */
FALSE, /* not strict */
TRUE, /* Output warnings
for non-
bool valid = grok_bslash_x(&p,
&result,
&error_msg,
- TRUE, /* out warnings */
+ PASS2, /* out warnings */
FALSE, /* not strict */
TRUE, /* Output warnings
for non-
}
case 'c':
p++;
- ender = grok_bslash_c(*p++, SIZE_ONLY);
+ ender = grok_bslash_c(*p++, PASS2);
break;
case '8': case '9': /* must be a backreference */
--p;
REQUIRE_UTF8;
}
p += numlen;
- if (SIZE_ONLY /* like \08, \178 */
+ if (PASS2 /* like \08, \178 */
&& numlen < 3
&& p < RExC_end
&& isDIGIT(*p) && ckWARN(WARN_REGEXP))
if (! RExC_override_recoding) {
SV* enc = PL_encoding;
ender = reg_recode((const char)(U8)ender, &enc);
- if (!enc && SIZE_ONLY)
+ if (!enc && PASS2)
ckWARNreg(p, "Invalid escape in the specified encoding");
REQUIRE_UTF8;
}
&& (PL_fold[ender] != PL_fold_latin1[ender]
|| ender == LATIN_SMALL_LETTER_SHARP_S
|| (len > 0
- && isARG2_lower_or_UPPER_ARG1('s', ender)
- && isARG2_lower_or_UPPER_ARG1('s',
- *(s-1)))))
+ && isALPHA_FOLD_EQ(ender, 's')
+ && isALPHA_FOLD_EQ(*(s-1), 's'))))
{
maybe_exactfu = FALSE;
}
* as if it turns into an EXACTFU, it could later get
* joined with another 's' that would then wrongly match
* the sharp s */
- if (maybe_exactfu && isARG2_lower_or_UPPER_ARG1('s', ender))
+ if (maybe_exactfu && isALPHA_FOLD_EQ(ender, 's'))
{
maybe_exactfu = FALSE;
}
UV high;
int i;
- if (end == UV_MAX && start <= 256) {
- ANYOF_FLAGS(node) |= ANYOF_ABOVE_LATIN1_ALL;
+ if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
+ ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
}
- else if (end >= 256) {
- ANYOF_FLAGS(node) |= ANYOF_UTF8;
+ else if (end >= NUM_ANYOF_CODE_POINTS) {
+ ANYOF_FLAGS(node) |= ANYOF_HAS_UTF8_NONBITMAP_MATCHES;
}
/* Quit if are above what we should change */
- if (start > 255) {
+ if (start >= NUM_ANYOF_CODE_POINTS) {
break;
}
change_invlist = TRUE;
/* Set all the bits in the range, up to the max that we are doing */
- high = (end < 255) ? end : 255;
+ high = (end < NUM_ANYOF_CODE_POINTS - 1)
+ ? end
+ : NUM_ANYOF_CODE_POINTS - 1;
for (i = start; i <= (int) high; i++) {
if (! ANYOF_BITMAP_TEST(node, i)) {
ANYOF_BITMAP_SET(node, i);
invlist_iterfinish(*invlist_ptr);
/* Done with loop; remove any code points that are in the bitmap from
- * *invlist_ptr; similarly for code points above latin1 if we have a
- * flag to match all of them anyways */
+ * *invlist_ptr; similarly for code points above the bitmap if we have
+ * a flag to match all of them anyways */
if (change_invlist) {
- _invlist_subtract(*invlist_ptr, PL_Latin1, invlist_ptr);
+ _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
}
- if (ANYOF_FLAGS(node) & ANYOF_ABOVE_LATIN1_ALL) {
- _invlist_intersection(*invlist_ptr, PL_Latin1, invlist_ptr);
+ if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
+ _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
}
/* If have completely emptied it, remove it completely */
* upon an unescaped ']' that isn't one ending a regclass. To do both
* these things, we need to realize that something preceded by a backslash
* is escaped, so we have to keep track of backslashes */
- if (SIZE_ONLY) {
- UV depth = 0; /* how many nested (?[...]) constructs */
-
+ if (PASS2) {
Perl_ck_warner_d(aTHX_
packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
"The regex_sets feature is experimental" REPORT_LOCATION,
UTF8fARG(UTF,
RExC_end - RExC_start - (RExC_parse - RExC_precomp),
RExC_precomp + (RExC_parse - RExC_precomp)));
+ }
+ else {
+ UV depth = 0; /* how many nested (?[...]) constructs */
while (RExC_parse < RExC_end) {
SV* current = NULL;
default:
/* Use deprecated warning to increase the chances of this being
* output */
- ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp);
+ if (PASS2) {
+ ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp);
+ }
break;
}
}
+STATIC AV *
+S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
+{
+ /* This adds the string scalar <multi_string> to the array
+ * <multi_char_matches>. <multi_string> is known to have exactly
+ * <cp_count> code points in it. This is used when constructing a
+ * bracketed character class and we find something that needs to match more
+ * than a single character.
+ *
+ * <multi_char_matches> is actually an array of arrays. Each top-level
+ * element is an array that contains all the strings known so far that are
+ * the same length. And that length (in number of code points) is the same
+ * as the index of the top-level array. Hence, the [2] element is an
+ * array, each element thereof is a string containing TWO code points;
+ * while element [3] is for strings of THREE characters, and so on. Since
+ * this is for multi-char strings there can never be a [0] nor [1] element.
+ *
+ * When we rewrite the character class below, we will do so such that the
+ * longest strings are written first, so that it prefers the longest
+ * matching strings first. This is done even if it turns out that any
+ * quantifier is non-greedy, out of this programmer's (khw) laziness. Tom
+ * Christiansen has agreed that this is ok. This makes the test for the
+ * ligature 'ffi' come before the test for 'ff', for example */
+
+ AV* this_array;
+ AV** this_array_ptr;
+
+ PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
+
+ if (! multi_char_matches) {
+ multi_char_matches = newAV();
+ }
+
+ if (av_exists(multi_char_matches, cp_count)) {
+ this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
+ this_array = *this_array_ptr;
+ }
+ else {
+ this_array = newAV();
+ av_store(multi_char_matches, cp_count,
+ (SV*) this_array);
+ }
+ av_push(this_array, multi_string);
+
+ return multi_char_matches;
+}
+
/* The names of properties whose definitions are not known at compile time are
* stored in this SV, after a constant heading. So if the length has been
* changed since initialization, then there is a run-time definition. */
* ignored in the recursion by means of a flag:
* <RExC_in_multi_char_class>.)
*
- * ANYOF nodes contain a bit map for the first 256 characters, with the
- * corresponding bit set if that character is in the list. For characters
- * above 255, a range list or swash is used. There are extra bits for \w,
- * etc. in locale ANYOFs, as what these match is not determinable at
- * compile time
+ * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
+ * characters, with the corresponding bit set if that character is in the
+ * list. For characters above this, a range list or swash is used. There
+ * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
+ * determinable at compile time
*
* Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs
* to be restarted. This can only happen if ret_invlist is non-NULL.
if (UCHARAT(RExC_parse) == ']')
goto charclassloop;
-parseit:
while (1) {
if (RExC_parse >= stop_ptr) {
break;
{
namedclass = regpposixcc(pRExC_state, value, strict);
}
- else if (value == '\\') {
- if (UTF) {
+ else if (value != '\\') {
+#ifdef EBCDIC
+ literal_endpoint++;
+#endif
+ }
+ else {
+ /* Is a backslash; get the code point of the char after it */
+ if (UTF && ! UTF8_IS_INVARIANT(RExC_parse)) {
value = utf8n_to_uvchr((U8*)RExC_parse,
RExC_end - RExC_parse,
&numlen, UTF8_ALLOW_DEFAULT);
case 'H': namedclass = ANYOF_NHORIZWS; break;
case 'N': /* Handle \N{NAME} in class */
{
- /* We only pay attention to the first char of
- multichar strings being returned. I kinda wonder
- if this makes sense as it does change the behaviour
- from earlier versions, OTOH that behaviour was broken
- as well. */
- if (! grok_bslash_N(pRExC_state, NULL, &value, flagp, depth,
- TRUE, /* => charclass */
- strict))
- {
- if (*flagp & RESTART_UTF8)
- FAIL("panic: grok_bslash_N set RESTART_UTF8");
- goto parseit;
+ SV *as_text;
+ STRLEN cp_count = grok_bslash_N(pRExC_state, NULL, &value,
+ flagp, depth, &as_text);
+ if (*flagp & RESTART_UTF8)
+ FAIL("panic: grok_bslash_N set RESTART_UTF8");
+ if (cp_count != 1) { /* The typical case drops through */
+ assert(cp_count != (STRLEN) -1);
+ if (cp_count == 0) {
+ if (strict) {
+ RExC_parse++; /* Position after the "}" */
+ vFAIL("Zero length \\N{}");
+ }
+ else if (PASS2) {
+ ckWARNreg(RExC_parse,
+ "Ignoring zero length \\N{} in character class");
+ }
+ }
+ else { /* cp_count > 1 */
+ if (! RExC_in_multi_char_class) {
+ if (invert || range || *RExC_parse == '-') {
+ if (strict) {
+ RExC_parse--;
+ vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character");
+ }
+ else if (PASS2) {
+ ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
+ }
+ }
+ else {
+ multi_char_matches
+ = add_multi_match(multi_char_matches,
+ as_text,
+ cp_count);
+ }
+ break; /* <value> contains the first code
+ point. Drop out of the switch to
+ process it */
+ }
+ } /* End of cp_count != 1 */
+
+ /* This element should not be processed further in this
+ * class */
+ element_count--;
+ value = save_value;
+ prevvalue = save_prevvalue;
+ continue; /* Back to top of loop to get next char */
}
+ /* Here, is a single code point, and <value> contains it */
}
break;
case 'p':
* inappropriately, except that any \p{}, including
* this one forces Unicode semantics, which means there
* is no <depends_list> */
- ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
+ ANYOF_FLAGS(ret)
+ |= ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES;
}
else {
case 't': value = '\t'; break;
case 'f': value = '\f'; break;
case 'b': value = '\b'; break;
- case 'e': value = ASCII_TO_NATIVE('\033');break;
+ case 'e': value = ESC_NATIVE; break;
case 'a': value = '\a'; break;
case 'o':
RExC_parse--; /* function expects to be pointed at the 'o' */
bool valid = grok_bslash_o(&RExC_parse,
&value,
&error_msg,
- SIZE_ONLY, /* warnings in pass
- 1 only */
+ PASS2, /* warnings only in
+ pass 2 */
strict,
silence_non_portable,
UTF);
bool valid = grok_bslash_x(&RExC_parse,
&value,
&error_msg,
- TRUE, /* Output warnings */
+ PASS2, /* Output warnings */
strict,
silence_non_portable,
UTF);
goto recode_encoding;
break;
case 'c':
- value = grok_bslash_c(*RExC_parse++, SIZE_ONLY);
+ value = grok_bslash_c(*RExC_parse++, PASS2);
break;
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7':
if (strict) {
vFAIL("Invalid escape in the specified encoding");
}
- else if (SIZE_ONLY) {
+ else if (PASS2) {
ckWARNreg(RExC_parse,
"Invalid escape in the specified encoding");
}
break;
} /* End of switch on char following backslash */
} /* end of handling backslash escape sequences */
-#ifdef EBCDIC
- else
- literal_endpoint++;
-#endif
/* Here, we have the current token in 'value' */
else {
RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
}
- ANYOF_FLAGS(ret) |= ANYOF_POSIXL;
+ ANYOF_FLAGS(ret) |= ANYOF_MATCHES_POSIXL;
ANYOF_POSIXL_ZERO(ret);
}
/* Coverity thinks it is possible for this to be negative; both
* jhi and khw think it's not, but be safer */
- assert(! (ANYOF_FLAGS(ret) & ANYOF_POSIXL)
+ assert(! (ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
|| (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0);
/* See if it already matches the complement of this POSIX
* class */
- if ((ANYOF_FLAGS(ret) & ANYOF_POSIXL)
+ if ((ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
&& ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2)
? -1
: 1)))
namedclass % 2 != 0,
posixes_ptr);
}
- continue; /* Go get next character */
}
} /* end of namedclass \blah */
- /* Here, we have a single value. If 'range' is set, it is the ending
- * of a range--check its validity. Later, we will handle each
- * individual code point in the range. If 'range' isn't set, this
- * could be the beginning of a range, so check for that by looking
- * ahead to see if the next real character to be processed is the range
- * indicator--the minus sign */
-
if (skip_white) {
RExC_parse = regpatws(pRExC_state, RExC_parse,
FALSE /* means don't recognize comments */ );
}
+ /* If 'range' is set, 'value' is the ending of a range--check its
+ * validity. (If value isn't a single code point in the case of a
+ * range, we should have figured that out above in the code that
+ * catches false ranges). Later, we will handle each individual code
+ * point in the range. If 'range' isn't set, this could be the
+ * beginning of a range, so check for that by looking ahead to see if
+ * the next real character to be processed is the range indicator--the
+ * minus sign */
+
if (range) {
if (prevvalue > value) /* b-a */ {
const int w = RExC_parse - rangebegin;
/* a bad range like \w-, [:word:]- ? */
if (namedclass > OOB_NAMEDCLASS) {
- if (strict || ckWARN(WARN_REGEXP)) {
- const int w =
- RExC_parse >= rangebegin ?
- RExC_parse - rangebegin : 0;
+ if (strict || (PASS2 && ckWARN(WARN_REGEXP))) {
+ const int w = RExC_parse >= rangebegin
+ ? RExC_parse - rangebegin
+ : 0;
if (strict) {
vFAIL4("False [] range \"%*.*s\"",
w, w, rangebegin);
}
- else {
+ else if (PASS2) {
vWARN4(RExC_parse,
"False [] range \"%*.*s\"",
w, w, rangebegin);
}
}
- /* Here, <prevvalue> is the beginning of the range, if any; or <value>
- * if not */
+ if (namedclass > OOB_NAMEDCLASS) {
+ continue;
+ }
+
+ /* Here, we have a single value, and <prevvalue> is the beginning of
+ * the range, if any; or <value> if not */
/* non-Latin1 code point implies unicode semantics. Must be set in
* pass1 so is there for the whole of pass 2 */
* again. Otherwise add this character to the list of
* multi-char folds. */
if (! RExC_in_multi_char_class) {
- AV** this_array_ptr;
- AV* this_array;
STRLEN cp_count = utf8_length(foldbuf,
foldbuf + foldlen);
SV* multi_fold = sv_2mortal(newSVpvs(""));
Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value);
+ multi_char_matches
+ = add_multi_match(multi_char_matches,
+ multi_fold,
+ cp_count);
- if (! multi_char_matches) {
- multi_char_matches = newAV();
- }
-
- /* <multi_char_matches> is actually an array of arrays.
- * There will be one or two top-level elements: [2],
- * and/or [3]. The [2] element is an array, each
- * element thereof is a character which folds to TWO
- * characters; [3] is for folds to THREE characters.
- * (Unicode guarantees a maximum of 3 characters in any
- * fold.) When we rewrite the character class below,
- * we will do so such that the longest folds are
- * written first, so that it prefers the longest
- * matching strings first. This is done even if it
- * turns out that any quantifier is non-greedy, out of
- * programmer laziness. Tom Christiansen has agreed
- * that this is ok. This makes the test for the
- * ligature 'ffi' come before the test for 'ff' */
- if (av_exists(multi_char_matches, cp_count)) {
- this_array_ptr = (AV**) av_fetch(multi_char_matches,
- cp_count, FALSE);
- this_array = *this_array_ptr;
- }
- else {
- this_array = newAV();
- av_store(multi_char_matches, cp_count,
- (SV*) this_array);
- }
- av_push(this_array, multi_fold);
}
/* This element should not be processed further in this
RExC_parse = SvPV(substitute_parse, len);
RExC_end = RExC_parse + len;
RExC_in_multi_char_class = 1;
+ RExC_override_recoding = 1;
RExC_emit = (regnode *)orig_emit;
ret = reg(pRExC_state, 1, ®_flags, depth+1);
RExC_parse = save_parse;
RExC_end = save_end;
RExC_in_multi_char_class = 0;
+ RExC_override_recoding = 0;
SvREFCNT_dec_NN(multi_char_matches);
return ret;
}
if (DEPENDS_SEMANTICS) {
/* Under /d, everything in the upper half of the Latin1 range
* matches these complements */
- ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_NON_ASCII_ALL;
+ ANYOF_FLAGS(ret) |= ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII;
}
else if (AT_LEAST_ASCII_RESTRICTED) {
/* Under /a and /aa, everything above ASCII matches these
else {
cp_list = depends_list;
}
- ANYOF_FLAGS(ret) |= ANYOF_UTF8;
+ ANYOF_FLAGS(ret) |= ANYOF_HAS_UTF8_NONBITMAP_MATCHES;
}
/* If there is a swash and more than one element, we can't use the swash in
swash = NULL;
}
+ /* Note that the optimization of using 'swash' if it is the only thing in
+ * the class doesn't have us change swash at all, so it can include things
+ * that are also in the bitmap; otherwise we have purposely deleted that
+ * duplicate information */
set_ANYOF_arg(pRExC_state, ret, cp_list,
(HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
? listsv : NULL,
{
/* Sets the arg field of an ANYOF-type node 'node', using information about
* the node passed-in. If there is nothing outside the node's bitmap, the
- * arg is set to ANYOF_NONBITMAP_EMPTY. Otherwise, it sets the argument to
+ * arg is set to ANYOF_ONLY_HAS_BITMAP. Otherwise, it sets the argument to
* the count returned by add_data(), having allocated and stored an array,
* av, that that count references, as follows:
* av[0] stores the character class description in its textual form.
if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
assert(! (ANYOF_FLAGS(node)
- & (ANYOF_UTF8|ANYOF_NONBITMAP_NON_UTF8)));
- ARG_SET(node, ANYOF_NONBITMAP_EMPTY);
+ & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES
+ |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES)));
+ ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
}
else {
AV * const av = newAV();
SV *rv;
assert(ANYOF_FLAGS(node)
- & (ANYOF_UTF8|ANYOF_NONBITMAP_NON_UTF8|ANYOF_LOC_FOLD));
+ & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES
+ |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES|ANYOF_LOC_FOLD));
av_store(av, 0, (runtime_defns)
? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
}
}
+#if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
+SV *
+Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
+ const regnode* node,
+ bool doinit,
+ SV** listsvp,
+ SV** only_utf8_locale_ptr,
+ SV* exclude_list)
+
+{
+ /* For internal core use only.
+ * Returns the swash for the input 'node' in the regex 'prog'.
+ * If <doinit> is 'true', will attempt to create the swash if not already
+ * done.
+ * If <listsvp> is non-null, will return the printable contents of the
+ * swash. This can be used to get debugging information even before the
+ * swash exists, by calling this function with 'doinit' set to false, in
+ * which case the components that will be used to eventually create the
+ * swash are returned (in a printable form).
+ * If <exclude_list> is not NULL, it is an inversion list of things to
+ * exclude from what's returned in <listsvp>.
+ * Tied intimately to how S_set_ANYOF_arg sets up the data structure. Note
+ * that, in spite of this function's name, the swash it returns may include
+ * the bitmap data as well */
+
+ SV *sw = NULL;
+ SV *si = NULL; /* Input swash initialization string */
+ SV* invlist = NULL;
+
+ RXi_GET_DECL(prog,progi);
+ const struct reg_data * const data = prog ? progi->data : NULL;
+
+ PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
+
+ assert(ANYOF_FLAGS(node)
+ & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES
+ |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES|ANYOF_LOC_FOLD));
+
+ if (data && data->count) {
+ const U32 n = ARG(node);
+
+ if (data->what[n] == 's') {
+ SV * const rv = MUTABLE_SV(data->data[n]);
+ AV * const av = MUTABLE_AV(SvRV(rv));
+ SV **const ary = AvARRAY(av);
+ U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
+
+ si = *ary; /* ary[0] = the string to initialize the swash with */
+
+ /* Elements 3 and 4 are either both present or both absent. [3] is
+ * any inversion list generated at compile time; [4] indicates if
+ * that inversion list has any user-defined properties in it. */
+ if (av_tindex(av) >= 2) {
+ if (only_utf8_locale_ptr
+ && ary[2]
+ && ary[2] != &PL_sv_undef)
+ {
+ *only_utf8_locale_ptr = ary[2];
+ }
+ else {
+ assert(only_utf8_locale_ptr);
+ *only_utf8_locale_ptr = NULL;
+ }
+
+ if (av_tindex(av) >= 3) {
+ invlist = ary[3];
+ if (SvUV(ary[4])) {
+ swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
+ }
+ }
+ else {
+ invlist = NULL;
+ }
+ }
+
+ /* Element [1] is reserved for the set-up swash. If already there,
+ * return it; if not, create it and store it there */
+ if (ary[1] && SvROK(ary[1])) {
+ sw = ary[1];
+ }
+ else if (doinit && ((si && si != &PL_sv_undef)
+ || (invlist && invlist != &PL_sv_undef))) {
+ assert(si);
+ sw = _core_swash_init("utf8", /* the utf8 package */
+ "", /* nameless */
+ si,
+ 1, /* binary */
+ 0, /* not from tr/// */
+ invlist,
+ &swash_init_flags);
+ (void)av_store(av, 1, sw);
+ }
+ }
+ }
+
+ /* If requested, return a printable version of what this swash matches */
+ if (listsvp) {
+ SV* matches_string = newSVpvs("");
+
+ /* The swash should be used, if possible, to get the data, as it
+ * contains the resolved data. But this function can be called at
+ * compile-time, before everything gets resolved, in which case we
+ * return the currently best available information, which is the string
+ * that will eventually be used to do that resolving, 'si' */
+ if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
+ && (si && si != &PL_sv_undef))
+ {
+ sv_catsv(matches_string, si);
+ }
+
+ /* Add the inversion list to whatever we have. This may have come from
+ * the swash, or from an input parameter */
+ if (invlist) {
+ if (exclude_list) {
+ SV* clone = invlist_clone(invlist);
+ _invlist_subtract(clone, exclude_list, &clone);
+ sv_catsv(matches_string, _invlist_contents(clone));
+ SvREFCNT_dec_NN(clone);
+ }
+ else {
+ sv_catsv(matches_string, _invlist_contents(invlist));
+ }
+ }
+ *listsvp = matches_string;
+ }
+
+ return sw;
+}
+#endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
/* reg_skipcomment()
}
if (r->intflags & PREGf_ANCH) {
PerlIO_printf(Perl_debug_log, "anchored");
- if (r->intflags & PREGf_ANCH_BOL)
- PerlIO_printf(Perl_debug_log, "(BOL)");
if (r->intflags & PREGf_ANCH_MBOL)
PerlIO_printf(Perl_debug_log, "(MBOL)");
if (r->intflags & PREGf_ANCH_SBOL)
);
if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
sv_catpvs(sv, "[");
- (void) put_latin1_charclass_innards(sv, IS_ANYOF_TRIE(op)
- ? ANYOF_BITMAP(o)
- : TRIE_BITMAP(trie));
+ (void) put_charclass_bitmap_innards(sv,
+ (IS_ANYOF_TRIE(op))
+ ? ANYOF_BITMAP(o)
+ : TRIE_BITMAP(trie),
+ NULL);
sv_catpvs(sv, "]");
}
else if (k == ANYOF) {
const U8 flags = ANYOF_FLAGS(o);
int do_sep = 0;
+ SV* bitmap_invlist; /* Will hold what the bit map contains */
if (flags & ANYOF_LOCALE_FLAGS)
if (flags & ANYOF_INVERT)
sv_catpvs(sv, "^");
- /* output what the standard cp 0-255 bitmap matches */
- do_sep = put_latin1_charclass_innards(sv, ANYOF_BITMAP(o));
+ /* output what the standard cp 0-NUM_ANYOF_CODE_POINTS-1 bitmap matches
+ * */
+ do_sep = put_charclass_bitmap_innards(sv, ANYOF_BITMAP(o),
+ &bitmap_invlist);
/* output any special charclass tests (used entirely under use
* locale) * */
}
}
- if ((flags & (ANYOF_ABOVE_LATIN1_ALL
- |ANYOF_UTF8
- |ANYOF_NONBITMAP_NON_UTF8
+ if ((flags & (ANYOF_MATCHES_ALL_ABOVE_BITMAP
+ |ANYOF_HAS_UTF8_NONBITMAP_MATCHES
+ |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES
|ANYOF_LOC_FOLD)))
{
if (do_sep) {
sv_catpvs(sv, "^");
}
- if (flags & ANYOF_NON_UTF8_NON_ASCII_ALL) {
+ if (flags & ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII) {
sv_catpvs(sv, "{non-utf8-latin1-all}");
}
/* output information about the unicode matching */
- if (flags & ANYOF_ABOVE_LATIN1_ALL)
- sv_catpvs(sv, "{unicode_all}");
- else if (ARG(o) != ANYOF_NONBITMAP_EMPTY) {
+ if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP)
+ sv_catpvs(sv, "{above_bitmap_all}");
+ else if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) {
SV *lv; /* Set if there is something outside the bit map. */
bool byte_output = FALSE; /* If something in the bitmap has
been output */
SV *only_utf8_locale;
- /* Get the stuff that wasn't in the bitmap */
+ /* Get the stuff that wasn't in the bitmap. 'bitmap_invlist'
+ * is used to guarantee that nothing in the bitmap gets
+ * returned */
(void) _get_regclass_nonbitmap_data(prog, o, FALSE,
- &lv, &only_utf8_locale);
+ &lv, &only_utf8_locale,
+ bitmap_invlist);
if (lv && lv != &PL_sv_undef) {
char *s = savesvpv(lv);
char * const origs = s;
if (*s == '\n') {
const char * const t = ++s;
- if (flags & ANYOF_NONBITMAP_NON_UTF8) {
+ if (flags & ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES) {
sv_catpvs(sv, "{outside bitmap}");
}
else {
invlist_iterinit(only_utf8_locale);
while (invlist_iternext(only_utf8_locale,
&start, &end)) {
- put_range(sv, start, end);
+ put_range(sv, start, end, FALSE);
max_entries --;
if (max_entries < 0) {
sv_catpvs(sv, "...");
}
}
}
+ SvREFCNT_dec(bitmap_invlist);
+
Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
}
}
else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
+ else if (OP(o) == SBOL)
+ Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
#else
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(sv);
Perl_croak(aTHX_ "%"UTF8f, UTF8fARG(utf8, l1-1, buf));
}
-/* XXX Here's a total kludge. But we need to re-enter for swash routines. */
-
-#ifndef PERL_IN_XSUB_RE
-void
-Perl_save_re_context(pTHX)
-{
- /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
- if (PL_curpm) {
- const REGEXP * const rx = PM_GETRE(PL_curpm);
- if (rx) {
- U32 i;
- for (i = 1; i <= RX_NPARENS(rx); i++) {
- char digits[TYPE_CHARS(long)];
- const STRLEN len = my_snprintf(digits, sizeof(digits),
- "%lu", (long)i);
- GV *const *const gvp
- = (GV**)hv_fetch(PL_defstash, digits, len, 0);
-
- if (gvp) {
- GV * const gv = *gvp;
- if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
- save_scalar(gv);
- }
- }
- }
- }
-}
-#endif
-
#ifdef DEBUGGING
+/* Certain characters are output as a sequence with the first being a
+ * backslash. */
+#define isBACKSLASHED_PUNCT(c) \
+ ((c) == '-' || (c) == ']' || (c) == '\\' || (c) == '^')
STATIC void
-S_put_byte(pTHX_ SV *sv, int c)
+S_put_code_point(pTHX_ SV *sv, UV c)
{
- PERL_ARGS_ASSERT_PUT_BYTE;
-
- if (!isPRINT(c)) {
- switch (c) {
- case '\r': Perl_sv_catpvf(aTHX_ sv, "\\r"); break;
- case '\n': Perl_sv_catpvf(aTHX_ sv, "\\n"); break;
- case '\t': Perl_sv_catpvf(aTHX_ sv, "\\t"); break;
- case '\f': Perl_sv_catpvf(aTHX_ sv, "\\f"); break;
- case '\a': Perl_sv_catpvf(aTHX_ sv, "\\a"); break;
+ PERL_ARGS_ASSERT_PUT_CODE_POINT;
- default:
- Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
- break;
- }
+ if (c > 255) {
+ Perl_sv_catpvf(aTHX_ sv, "\\x{%04"UVXf"}", c);
}
- else {
- const char string = c;
- if (c == '-' || c == ']' || c == '\\' || c == '^')
+ else if (isPRINT(c)) {
+ const char string = (char) c;
+ if (isBACKSLASHED_PUNCT(c))
sv_catpvs(sv, "\\");
sv_catpvn(sv, &string, 1);
}
+ else {
+ const char * const mnemonic = cntrl_to_mnemonic((char) c);
+ if (mnemonic) {
+ Perl_sv_catpvf(aTHX_ sv, "%s", mnemonic);
+ }
+ else {
+ Perl_sv_catpvf(aTHX_ sv, "\\x{%02X}", (U8) c);
+ }
+ }
}
+#define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
+
+#ifndef MIN
+#define MIN(a,b) ((a) < (b) ? (a) : (b))
+#endif
+
STATIC void
-S_put_range(pTHX_ SV *sv, UV start, UV end)
+S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
{
-
/* Appends to 'sv' a displayable version of the range of code points from
* '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 */
+ * as-is (though some of these will be escaped by put_code_point()). */
+
+ const unsigned int min_range_count = 3;
assert(start <= end);
PERL_ARGS_ASSERT_PUT_RANGE;
while (start <= end) {
- if (end - start < 3) { /* Individual chars in short ranges */
+ UV this_end;
+ const char * format;
+
+ if (end - start < min_range_count) {
+
+ /* Individual chars in short ranges */
for (; start <= end; start++) {
- put_byte(sv, start);
+ put_code_point(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 permitted by the input options, and there is a possibility that
+ * this range contains a printable literal, look to see if there is
+ * one. */
+ if (allow_literals && start <= MAX_PRINT_A) {
+
+ /* If the range begin isn't an ASCII printable, effectively split
+ * the range into two parts:
+ * 1) the portion before the first such printable,
+ * 2) the rest
+ * and output them separately. */
if (! isPRINT_A(start)) {
UV temp_end = start + 1;
- while (temp_end <= end && ! isPRINT_A(temp_end)) {
+
+ /* There is no point looking beyond the final possible
+ * printable, in MAX_PRINT_A */
+ UV max = MIN(end, MAX_PRINT_A);
+
+ while (temp_end <= max && ! isPRINT_A(temp_end)) {
temp_end++;
}
- if (temp_end <= end) {
- put_range(sv, start, temp_end - 1);
- start = temp_end;
- continue;
+
+ /* Here, temp_end points to one beyond the first printable if
+ * found, or to one beyond 'max' if not. If none found, make
+ * sure that we use the entire range */
+ if (temp_end > MAX_PRINT_A) {
+ temp_end = end + 1;
}
- }
- /* 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);
+ /* Output the first part of the split range, the part that
+ * doesn't have printables, with no looking for literals
+ * (otherwise we would infinitely recurse) */
+ put_range(sv, start, temp_end - 1, FALSE);
+
+ /* The 2nd part of the range (if any) starts here. */
+ start = temp_end;
+
+ /* We continue instead of dropping down because even if the 2nd
+ * part is non-empty, it could be so short that we want to
+ * output it specially, as tested for at the top of this loop.
+ * */
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);
+ /* Here, 'start' is a printable ASCII. If it is an alphanumeric,
+ * output a sub-range of just the digits or letters, then process
+ * the remaining portion as usual. */
+ if (isALPHANUMERIC_A(start)) {
+ UV mask = (isDIGIT_A(start))
+ ? _CC_DIGIT
+ : isUPPER_A(start)
+ ? _CC_UPPER
+ : _CC_LOWER;
+ UV temp_end = start + 1;
+
+ /* Find the end of the sub-range that includes just the
+ * characters in the same class as the first character in it */
+ while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
+ temp_end++;
+ }
+ temp_end--;
+
+ /* For short ranges, don't duplicate the code above to output
+ * them; just call recursively */
+ if (temp_end - start < min_range_count) {
+ put_range(sv, start, temp_end, FALSE);
+ }
+ else { /* Output as a range */
+ put_code_point(sv, start);
+ sv_catpvs(sv, "-");
+ put_code_point(sv, temp_end);
+ }
+ start = temp_end + 1;
continue;
}
- /* We output any remaining printables as individual characters */
+ /* We output any other printables as individual characters */
if (isPUNCT_A(start) || isSPACE_A(start)) {
- while (start <= end && (isPUNCT_A(start) || isSPACE_A(start))) {
- put_byte(sv, start);
+ while (start <= end && (isPUNCT_A(start)
+ || isSPACE_A(start)))
+ {
+ put_code_point(sv, start);
start++;
}
continue;
}
+ } /* End of looking for literals */
+
+ /* Here is not to output as a literal. Some control characters have
+ * mnemonic names. Split off any of those at the beginning and end of
+ * the range to print mnemonically. It isn't possible for many of
+ * these to be in a row, so this won't overwhelm with output */
+ while (isMNEMONIC_CNTRL(start) && start <= end) {
+ put_code_point(sv, start);
+ start++;
}
+ if (start < end && isMNEMONIC_CNTRL(end)) {
+
+ /* Here, the final character in the range has a mnemonic name.
+ * Work backwards from the end to find the final non-mnemonic */
+ UV temp_end = end - 1;
+ while (isMNEMONIC_CNTRL(temp_end)) {
+ temp_end--;
+ }
- /* 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);
+ /* And separately output the range that doesn't have mnemonics */
+ put_range(sv, start, temp_end, FALSE);
+
+ /* Then output the mnemonic trailing controls */
+ start = temp_end + 1;
+ while (start <= end) {
+ put_code_point(sv, start);
+ start++;
+ }
+ break;
+ }
+
+ /* As a final resort, output the range or subrange as hex. */
+
+ this_end = (end < NUM_ANYOF_CODE_POINTS)
+ ? end
+ : NUM_ANYOF_CODE_POINTS - 1;
+ format = (this_end < 256)
+ ? "\\x{%02"UVXf"}-\\x{%02"UVXf"}"
+ : "\\x{%04"UVXf"}-\\x{%04"UVXf"}";
+ Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
break;
}
}
STATIC bool
-S_put_latin1_charclass_innards(pTHX_ SV *sv, char *bitmap)
+S_put_charclass_bitmap_innards(pTHX_ SV *sv, char *bitmap, SV** bitmap_invlist)
{
/* Appends to 'sv' a displayable version of the innards of the bracketed
* character class whose bitmap is 'bitmap'; Returns 'TRUE' if it actually
- * output anything */
+ * output anything, and bitmap_invlist, if not NULL, will point to an
+ * inversion list of what is in the bit map */
int i;
- bool has_output_anything = FALSE;
+ UV start, end;
+ unsigned int punct_count = 0;
+ SV* invlist = NULL;
+ SV** invlist_ptr; /* Temporary, in case bitmap_invlist is NULL */
+ bool allow_literals = TRUE;
+
+ PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
+
+ invlist_ptr = (bitmap_invlist) ? bitmap_invlist : &invlist;
+
+ /* Worst case is exactly every-other code point is in the list */
+ *invlist_ptr = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
+
+ /* Convert the bit map to an inversion list, keeping track of how many
+ * ASCII puncts are set, including an extra amount for the backslashed
+ * ones. */
+ for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
+ if (BITMAP_TEST(bitmap, i)) {
+ *invlist_ptr = add_cp_to_invlist(*invlist_ptr, i);
+ if (isPUNCT_A(i)) {
+ punct_count++;
+ if isBACKSLASHED_PUNCT(i) {
+ punct_count++;
+ }
+ }
+ }
+ }
- PERL_ARGS_ASSERT_PUT_LATIN1_CHARCLASS_INNARDS;
+ /* Nothing to output */
+ if (_invlist_len(*invlist_ptr) == 0) {
+ SvREFCNT_dec(invlist);
+ return FALSE;
+ }
- for (i = 0; i < 256; i++) {
- if (BITMAP_TEST((U8 *) bitmap,i)) {
+ /* Generally, it is more readable if printable characters are output as
+ * literals, but if a range (nearly) spans all of them, it's best to output
+ * it as a single range. This code will use a single range if all but 2
+ * printables are in it */
+ invlist_iterinit(*invlist_ptr);
+ while (invlist_iternext(*invlist_ptr, &start, &end)) {
- /* The character at index i should be output. Find the next
- * character that should NOT be output */
- int j;
- for (j = i + 1; j < 256; j++) {
- if (! BITMAP_TEST((U8 *) bitmap, j)) {
- break;
- }
- }
+ /* If range starts beyond final printable, it doesn't have any in it */
+ if (start > MAX_PRINT_A) {
+ break;
+ }
- /* Everything between them is a single range that should be output
- * */
- put_range(sv, i, j - 1);
- has_output_anything = TRUE;
- i = j;
+ /* In both ASCII and EBCDIC, a SPACE is the lowest printable. To span
+ * all but two, the range must start and end no later than 2 from
+ * either end */
+ if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
+ if (end > MAX_PRINT_A) {
+ end = MAX_PRINT_A;
+ }
+ if (start < ' ') {
+ start = ' ';
+ }
+ if (end - start >= MAX_PRINT_A - ' ' - 2) {
+ allow_literals = FALSE;
+ }
+ break;
}
}
+ invlist_iterfinish(*invlist_ptr);
+
+ /* The legibility of the output depends mostly on how many punctuation
+ * characters are output. There are 32 possible ASCII ones, and some have
+ * an additional backslash, bringing it to currently 36, so if any more
+ * than 18 are to be output, we can instead output it as its complement,
+ * yielding fewer puncts, and making it more legible. But give some weight
+ * to the fact that outputting it as a complement is less legible than a
+ * straight output, so don't complement unless we are somewhat over the 18
+ * mark */
+ if (allow_literals && punct_count > 22) {
+ sv_catpvs(sv, "^");
+
+ /* Add everything remaining to the list, so when we invert it just
+ * below, it will be excluded */
+ _invlist_union_complement_2nd(*invlist_ptr, PL_InBitmap, invlist_ptr);
+ _invlist_invert(*invlist_ptr);
+ }
+
+ /* Here we have figured things out. Output each range */
+ invlist_iterinit(*invlist_ptr);
+ while (invlist_iternext(*invlist_ptr, &start, &end)) {
+ if (start >= NUM_ANYOF_CODE_POINTS) {
+ break;
+ }
+ put_range(sv, start, end, allow_literals);
+ }
+ invlist_iterfinish(*invlist_ptr);
- return has_output_anything;
+ return TRUE;
}
#define CLEAR_OPTSTART \
}
else if (PL_regkind[(U8)op] == ANYOF) {
/* arglen 1 + class block */
- node += 1 + ((ANYOF_FLAGS(node) & ANYOF_POSIXL)
+ node += 1 + ((ANYOF_FLAGS(node) & ANYOF_MATCHES_POSIXL)
? ANYOF_POSIXL_SKIP
: ANYOF_SKIP);
node = NEXTOPER(node);
#define PREGf_GPOS_SEEN 0x00000100
#define PREGf_GPOS_FLOAT 0x00000200
-#define PREGf_ANCH_BOL 0x00000400
-#define PREGf_ANCH_MBOL 0x00000800
-#define PREGf_ANCH_SBOL 0x00001000
-#define PREGf_ANCH_GPOS 0x00002000
+#define PREGf_ANCH_MBOL 0x00000400
+#define PREGf_ANCH_SBOL 0x00000800
+#define PREGf_ANCH_GPOS 0x00001000
-#define PREGf_ANCH (PREGf_ANCH_SBOL | PREGf_ANCH_GPOS | \
- PREGf_ANCH_MBOL | PREGf_ANCH_BOL )
+#define PREGf_ANCH \
+ ( PREGf_ANCH_SBOL | PREGf_ANCH_GPOS | PREGf_ANCH_MBOL )
/* this is where the old regcomp.h started */
U16 arg2;
};
-
-#define ANYOF_BITMAP_SIZE (256 / 8) /* 8 bits/Byte */
+/* This give the number of code points that can be in the bitmap of an ANYOF
+ * node. The shift number must currently be one of: 8..12. It can't be less
+ * than 8 (256) because some code relies on it being at least that. Above 12
+ * (4096), and you start running into warnings that some data structure widths
+ * have been exceeded, though the test suite as of this writing still passes
+ * for up through 16, which is as high as anyone would ever want to go,
+ * encompassing all of the Unicode BMP, and thus including all the economically
+ * important world scripts. At 12 most of them are: including Arabic,
+ * Cyrillic, Greek, Hebrew, Indian subcontinent, Latin, and Thai; but not Han,
+ * Japanese, nor Korean. (The regarglen structure in regnodes.h is a U8, and
+ * the trie types TRIEC and AHOCORASICKC are larger than U8 for shift values
+ * below above 12.) Be sure to benchmark before changing, as larger sizes do
+ * significantly slow down the test suite */
+#define NUM_ANYOF_CODE_POINTS (1 << 8)
+
+#define ANYOF_BITMAP_SIZE (NUM_ANYOF_CODE_POINTS / 8) /* 8 bits/Byte */
/* Note that these form structs which are supersets of the next smaller one, by
* appending fields. Alignment problems can occur if one of those optional
/* has runtime (locale) \d, \w, ..., [:posix:] classes */
struct regnode_charclass_class {
- U8 flags; /* ANYOF_POSIXL bit must go here */
+ U8 flags; /* ANYOF_MATCHES_POSIXL bit must go here */
U8 type;
U16 next_off;
U32 arg1;
- char bitmap[ANYOF_BITMAP_SIZE]; /* both compile-time */
+ char bitmap[ANYOF_BITMAP_SIZE]; /* both compile-time ... */
U32 classflags; /* and run-time */
};
* have a pointer field because there is no alignment issue, and because it is
* set to NULL after construction, before any cloning of the pattern */
struct regnode_ssc {
- U8 flags; /* ANYOF_POSIXL bit must go here */
+ U8 flags; /* ANYOF_MATCHES_POSIXL bit must go here */
U8 type;
U16 next_off;
U32 arg1;
- char bitmap[ANYOF_BITMAP_SIZE]; /* both compile-time */
+ char bitmap[ANYOF_BITMAP_SIZE]; /* both compile-time ... */
U32 classflags; /* and run-time */
/* Auxiliary, only used during construction; NULL afterwards: list of code
#define NEXT_OFF(p) ((p)->next_off)
#define NODE_ALIGN(node)
-#define NODE_ALIGN_FILL(node) ((node)->flags = 0xde) /* deadbeef */
+/* the following define was set to 0xde in 075abff3
+ * as part of some linting logic. I have set it to 0
+ * as otherwise in every place where we /might/ set flags
+ * we have to set it 0 explicitly, which duplicates
+ * assignments and IMO adds an unacceptable level of
+ * surprise to working in the regex engine. If this
+ * is changed from 0 then at the very least make sure
+ * that SBOL for /^/ sets the flags to 0 explicitly.
+ * -- Yves */
+#define NODE_ALIGN_FILL(node) ((node)->flags = 0)
#define SIZE_ALIGN NODE_ALIGN
#define PASS1 SIZE_ONLY
#define PASS2 (! SIZE_ONLY)
-/* If the bitmap doesn't fully represent what this ANYOF node can match, the
+/* If the bitmap fully represents what this ANYOF node can match, the
* ARG is set to this special value (since 0, 1, ... are legal, but will never
* reach this high). */
-#define ANYOF_NONBITMAP_EMPTY ((U32) -1)
+#define ANYOF_ONLY_HAS_BITMAP ((U32) -1)
/* Flags for node->flags of ANYOF. These are in short supply, with none
- * currently available. The ABOVE_LATIN1_ALL bit could be freed up
+ * currently available. The ABOVE_BITMAP_ALL bit could be freed up
* by resorting to creating a swash containing everything above 255. This
* introduces a performance penalty. An option that wouldn't slow things down
* would be to split one of the two LOC flags out into a separate
* only for /d, so there are no combinatorial issues. The LOC flag to use is
* probably the POSIXL one.
* Several flags are not used in synthetic start class (SSC) nodes, so could be
- * shared should new flags be needed for SSCs, like ANYOF_EMPTY_STRING now. */
+ * shared should new flags be needed for SSCs, like SSC_MATCHES_EMPTY_STRING
+ * now. */
/* regexec.c is expecting this to be in the low bit */
-#define ANYOF_INVERT 0x01
+#define ANYOF_INVERT 0x01
/* For the SSC node only, which cannot be inverted, so is shared with that bit.
- * This means "Does this SSC match an empty string?" This is used only during
- * regex compilation. */
-#define ANYOF_EMPTY_STRING ANYOF_INVERT
+ * This is used only during regex compilation. */
+#define SSC_MATCHES_EMPTY_STRING ANYOF_INVERT
-/* Are there things that will match only if the target string is encoded in
- * UTF-8? (This is not set if ANYOF_AOVE_LATIN1_ALL is set) */
-#define ANYOF_UTF8 0x02
+/* Are there things outside the bitmap that will match only if the target
+ * string is encoded in UTF-8? (This is not set if ANYOF_ABOVE_BITMAP_ALL is
+ * set) */
+#define ANYOF_HAS_UTF8_NONBITMAP_MATCHES 0x02
/* The fold is calculated and stored in the bitmap where possible at compile
* time. However under locale, the actual folding varies depending on
* what the locale is at the time of execution, so it has to be deferred until
* then */
-#define ANYOF_LOC_FOLD 0x04
+#define ANYOF_LOC_FOLD 0x04
/* Set if this is a regnode_charclass_posixl vs a regnode_charclass. This
* is used for runtime \d, \w, [:posix:], ..., which are used only in locale
* and the optimizer's synthetic start class. Non-locale \d, etc are resolved
* at compile-time */
-#define ANYOF_POSIXL 0x08
-#define ANYOF_CLASS ANYOF_POSIXL
-#define ANYOF_LARGE ANYOF_POSIXL
+#define ANYOF_MATCHES_POSIXL 0x08
/* Should we raise a warning if matching against an above-Unicode code point?
* */
-#define ANYOF_WARN_SUPER 0x10
+#define ANYOF_WARN_SUPER 0x10
/* Can match something outside the bitmap that isn't in utf8 */
-#define ANYOF_NONBITMAP_NON_UTF8 0x20
+#define ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES 0x20
-/* Matches every code point 0x100 and above*/
-#define ANYOF_ABOVE_LATIN1_ALL 0x40
-#define ANYOF_UNICODE_ALL ANYOF_ABOVE_LATIN1_ALL
+/* Matches every code point NUM_ANYOF_CODE_POINTS and above*/
+#define ANYOF_MATCHES_ALL_ABOVE_BITMAP 0x40
/* Match all Latin1 characters that aren't ASCII when the target string is not
* in utf8. */
-#define ANYOF_NON_UTF8_NON_ASCII_ALL 0x80
+#define ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII 0x80
#define ANYOF_FLAGS_ALL (0xff)
-#define ANYOF_LOCALE_FLAGS (ANYOF_LOC_FOLD | ANYOF_POSIXL)
+#define ANYOF_LOCALE_FLAGS (ANYOF_LOC_FOLD | ANYOF_MATCHES_POSIXL)
/* These are the flags that apply to both regular ANYOF nodes and synthetic
* start class nodes during construction of the SSC. During finalization of
* the SSC, other of the flags could be added to it */
-#define ANYOF_COMMON_FLAGS (ANYOF_WARN_SUPER|ANYOF_UTF8)
+#define ANYOF_COMMON_FLAGS (ANYOF_WARN_SUPER|ANYOF_HAS_UTF8_NONBITMAP_MATCHES)
/* Character classes for node->classflags of ANYOF */
/* Should be synchronized with a table in regprop() */
#define ANYOF_FLAGS(p) ((p)->flags)
-#define ANYOF_BIT(c) (1 << ((c) & 7))
+#define ANYOF_BIT(c) (1U << ((c) & 7))
#define ANYOF_POSIXL_SET(p, c) (((regnode_charclass_posixl*) (p))->classflags |= (1U << (c)))
#define ANYOF_CLASS_SET(p, c) ANYOF_POSIXL_SET((p), (c))
#define ANYOF_CLASS_SETALL(ret) ANYOF_POSIXL_SETALL(ret)
#define ANYOF_POSIXL_TEST_ANY_SET(p) \
- ((ANYOF_FLAGS(p) & ANYOF_POSIXL) \
+ ((ANYOF_FLAGS(p) & ANYOF_MATCHES_POSIXL) \
&& (((regnode_charclass_posixl*)(p))->classflags))
#define ANYOF_CLASS_TEST_ANY_SET(p) ANYOF_POSIXL_TEST_ANY_SET(p)
== ((1U << ((ANYOF_POSIXL_MAX) - 1))) - 1)
#define ANYOF_POSIXL_TEST_ALL_SET(p) \
- ((ANYOF_FLAGS(p) & ANYOF_POSIXL) \
+ ((ANYOF_FLAGS(p) & ANYOF_MATCHES_POSIXL) \
&& ((regnode_charclass_posixl*) (p))->classflags \
== ((1U << ((ANYOF_POSIXL_MAX) - 1))) - 1)
#define ANYOF_BITMAP_BYTE(p, c) (ANYOF_BITMAP(p)[(((U8)(c)) >> 3) & 31])
#define ANYOF_BITMAP_SET(p, c) (ANYOF_BITMAP_BYTE(p, c) |= ANYOF_BIT(c))
#define ANYOF_BITMAP_CLEAR(p,c) (ANYOF_BITMAP_BYTE(p, c) &= ~ANYOF_BIT(c))
-#define ANYOF_BITMAP_TEST(p, c) (ANYOF_BITMAP_BYTE(p, c) & ANYOF_BIT(c))
+#define ANYOF_BITMAP_TEST(p, c) cBOOL(ANYOF_BITMAP_BYTE(p, c) & ANYOF_BIT(c))
#define ANYOF_BITMAP_SETALL(p) \
memset (ANYOF_BITMAP(p), 255, ANYOF_BITMAP_SIZE)
#define ANYOF_BITMAP_CLEARALL(p) \
Zero (ANYOF_BITMAP(p), ANYOF_BITMAP_SIZE)
-/* Check that all 256 bits are all set. Used in S_cl_is_anything() */
-#define ANYOF_BITMAP_TESTALLSET(p) /* Assumes sizeof(p) == 32 */ \
- memEQ (ANYOF_BITMAP(p), "\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377", ANYOF_BITMAP_SIZE)
#define ANYOF_SKIP ((ANYOF_SIZE - 1)/sizeof(regnode))
#define ANYOF_POSIXL_SKIP ((ANYOF_POSIXL_SIZE - 1)/sizeof(regnode))
END END, no ; End of program.
SUCCEED END, no ; Return from a subroutine, basically.
-#* Anchors:
-
-BOL BOL, no ; Match "" at beginning of line.
-MBOL BOL, no ; Same, assuming multiline.
-SBOL BOL, no ; Same, assuming singleline.
-EOS EOL, no ; Match "" at end of string.
-EOL EOL, no ; Match "" at end of line.
-MEOL EOL, no ; Same, assuming multiline.
-SEOL EOL, no ; Same, assuming singleline.
+#* Line Start Anchors:
+#Note flags field for SBOL indicates if it is a /^/ or a /\A/
+SBOL BOL, no ; Match "" at beginning of line: /^/, /\A/
+MBOL BOL, no ; Same, assuming multiline: /^/m
+
+#* Line End Anchors:
+SEOL EOL, no ; Match "" at end of line: /$/
+MEOL EOL, no ; Same, assuming multiline: /$/m
+EOS EOL, no ; Match "" at end of string: /\z/
+
+#* Match Start Anchors:
+GPOS GPOS, no ; Matches where last m//g left off.
+
+#* Word Boundary Opcodes:
# The regops that have varieties that vary depending on the character set regex
# modifiers have to ordered thusly: /d, /l, /u, /a, /aa. This is because code
# in regcomp.c uses the enum value of the modifier as an offset from the /d
NBOUNDL NBOUND, no ; Match "" at any locale word non-boundary
NBOUNDU NBOUND, no ; Match "" at any word non-boundary using Unicode rules
NBOUNDA NBOUND, no ; Match "" at any word non-boundary using ASCII rules
-GPOS GPOS, no ; Matches where last m//g left off.
#* [Special] alternatives:
-
REG_ANY REG_ANY, no 0 S ; Match any one character (except newline).
SANY REG_ANY, no 0 S ; Match any one character.
CANY REG_ANY, no 0 S ; Match any one byte.
ANYOF ANYOF, sv 0 S ; Match character in (or not in) this class, single char match only
+#* POSIX Character Classes:
# Order of the below is important. See ordering comment above.
POSIXD POSIXD, none 0 S ; Some [[:class:]] under /d; the FLAGS field gives which one
POSIXL POSIXD, none 0 S ; Some [[:class:]] under /l; the FLAGS field gives which one
NREFFU REF, num 1 V ; Match already matched string, folded using unicode rules for non-utf8
NREFFA REF, num 1 V ; Match already matched string, folded using unicode rules for non-utf8, no mixing ASCII, non-ASCII
+#*Support for long RE
+LONGJMP LONGJMP, off 1 . 1 ; Jump far away.
+BRANCHJ BRANCHJ, off 1 V 1 ; BRANCH with long offset.
+
+#*Special Case Regops
IFMATCH BRANCHJ, off 1 . 2 ; Succeeds if the following matches.
UNLESSM BRANCHJ, off 1 . 2 ; Fails if the following matches.
SUSPEND BRANCHJ, off 1 V 1 ; "Independent" sub-RE.
IFTHEN BRANCHJ, off 1 V 1 ; Switch, should be preceded by switcher.
GROUPP GROUPP, num 1 ; Whether the group matched.
-#*Support for long RE
-
-LONGJMP LONGJMP, off 1 . 1 ; Jump far away.
-BRANCHJ BRANCHJ, off 1 V 1 ; BRANCH with long offset.
#*The heavy worker
XDIGIT
VERTSPACE
IS_IN_SOME_FOLD
+ MNEMONIC_CNTRL
);
# Read in the case fold mappings.
$re = qr/\p{Is_Non_Final_Fold}/;
} elsif ($name eq 'IS_IN_SOME_FOLD') {
$re = qr/\p{_Perl_Any_Folds}/;
+ } elsif ($name eq 'MNEMONIC_CNTRL') {
+ # These are the control characters that there are mnemonics for
+ $re = qr/[\a\b\e\f\n\r\t]/;
} else { # The remainder have the same name and values as Unicode
$re = eval "qr/\\p{$name}/";
use Carp;
--- /dev/null
+#!perl
+
+=head1 F<regen/op_private>
+
+This file contains all the definitions of the meanings of the flags in the
+op_private field of an OP.
+
+After editing this file, run C<make regen>. This will generate/update data
+in:
+
+ opcode.h
+ lib/B/Op_private.pm
+
+C<B::Op_private> holds three global hashes, C<%bits>, C<%defines>,
+C<%labels>, which hold roughly the same information as found in this file
+(after processing).
+
+F<opcode.h> gains a series of C<OPp*> defines, and a few static data
+structures:
+
+C<PL_op_private_valid> defines, per-op, which op_private bits are legally
+allowed to be set. This is a good first place to look to see if an op has
+any spare private bits.
+
+C<PL_op_private_bitdef_ix>, C<PL_op_private_bitdefs>,
+C<PL_op_private_labels>, C<PL_op_private_bitfields>,
+C<PL_op_private_valid> contain (in a compact form) the data needed by
+Perl_do_op_dump() to dump the op_private field of an op.
+
+This file actually contains perl code which is run by F<regen/opcode.pl>.
+The basic idea is that you keep calling addbits() to add definitions of
+what a particular bit or range of bits in op_private means for a
+particular op. This can be specified either as a 1-bit flag or a 1-or-more
+bit bit field. Here's a general example:
+
+ addbits('aelem',
+ 7 => qw(OPpLVAL_INTRO LVINTRO),
+ '5..6' => {
+ mask_def => 'OPpDEREF',
+ enum => [ qw(
+ 1 OPpDEREF_AV DREFAV
+ 2 OPpDEREF_HV DREFHV
+ 3 OPpDEREF_SV DREFSV
+ )],
+ },
+ 4 => qw(OPpLVAL_DEFER LVDEFER),
+ );
+
+Here for the op C<aelem>, bits 4 and 7 (bits are numbered 0..7) are
+defined as single-bit flags. The first string following the bit number is
+the define name that gets emitted in F<opcode.h>, and the second string is
+the label, which will be displayed by F<Concise.pm> and Perl_do_op_dump()
+(as used by C<perl -Dx>).
+
+If the bit number is actually two numbers connected with '..', then this
+defines a bit field, which is 1 or more bits taken to hold a small
+unsigned integer. Instead of two string arguments, it just has a single
+hash ref argument. A bit field allows you to generate extra defines, such
+as a mask, and optionally allows you to define an enumeration, where a
+subset of the possible values of the bit field are given their own defines
+and labels. The full syntax of this hash is explained further below.
+
+Note that not all bits for a particular op need to be added in a single
+addbits() call; they accumulate. In particular, this file is arranged in
+two halves; first, generic flags shared by multiple ops are added, then
+in the second half, specific per-op flags are added, e.g.
+
+ addbits($_, 7 => qw(OPpLVAL_INTRO LVINTRO)) for qw(pos substr vec ...);
+
+ ....
+
+ addbits('substr',
+ 4 => qw(OPpSUBSTR_REPL_FIRST REPL1ST),
+ 3 => ...
+ );
+
+(although the dividing line between these two halves is somewhat
+subjective, and is based on whether "OPp" is followed by the op name or
+something generic).
+
+There are some utility functions for generating a list of ops from
+F<regen/opcodes> based on various criteria. These are:
+
+ ops_with_check('ck_foo')
+ ops_with_flag('X')
+ ops_with_arg(N, 'XYZ')
+
+which respectively return a list of op names where:
+
+ field 3 of regen/opcodes specifies 'ck_foo' as the check function;
+ field 4 of of regen/opcodes has flag or type 'X' set;
+ argument field N of of regen/opcodes matches 'XYZ';
+
+For example
+
+ addbits($_, 4 => qw(OPpTARGET_MY TARGMY)) for ops_with_flag('T');
+
+If a label is specified as '-', then the flag or bit field is not
+displayed symbolically by Concise/-Dx; instead the bits are treated as
+unrecognised and are included in the final residual integer value after
+all recognised bits have been processed (this doesn't apply to individual
+enum labels).
+
+Here is a full example of a bit field hash:
+
+ '5..6' => {
+ mask_def => 'OPpFOO_MASK',
+ baseshift_def => 'OPpFOO_SHIFT',
+ bitcount_def => 'OPpFOO_BITS',
+ label => 'FOO',
+ enum => [ qw(
+ 1 OPpFOO_A A
+ 2 OPpFOO_B B
+ 3 OPpFOO_C C
+ )],
+ };
+
+The optional C<*_def> keys cause defines to be emitted that specify
+useful values based on the bit range (5 to 6 in this case):
+
+ mask_def: a mask that will extract the bit field
+ baseshift_def: how much to shift to make the bit field reach bit 0
+ bitcount_def: how many bits make up the bit field
+
+The example above will generate
+
+ #define OPpFOO_MASK 0x60
+ #define OPpFOO_SHIFT 5
+ #define OPpFOO_BITS 2
+
+The optional enum list specifies a set of defines and labels for (possibly
+a subset of) the possible values of the bit field (which in this example
+are 0,1,2,3). If a particular value matches an enum, then it will be
+displayed symbolically (e.g. 'C'), otherwise as a small integer. The
+defines are suitably shifted. The example above will generate
+
+ #define OPpFOO_A 0x20
+ #define OPpFOO_B 0x40
+ #define OPpFOO_C 0x60
+
+So you can write code like
+
+ if ((o->op_private & OPpFOO_MASK) == OPpFOO_C) ...
+
+The optional 'label' key causes Concise/-Dx output to prefix the value
+with C<LABEL=>; so in this case it might display C<FOO=C>. If the field
+value is zero, and if no label is present, and if no enum matches, then
+the field isn't displayed.
+
+=cut
+
+
+use warnings;
+use strict;
+
+
+
+
+# ====================================================================
+#
+# GENERIC OPpFOO flags
+#
+# Flags where FOO is a generic term (like LVAL), and the flag is
+# shared between multiple (possibly unrelated) ops.
+
+
+
+
+{
+ # The lower few bits of op_private often indicate the number of
+ # arguments. This is usually set by newUNOP() and newLOGOP (to 1),
+ # by newBINOP() (to 1 or 2), and by ck_fun() (to 1..15).
+ #
+ # These values are sometimes used at runtime: in particular,
+ # the MAXARG macro extracts out the lower 4 bits.
+ #
+ # Some ops encroach upon these bits; for example, entersub is a unop,
+ # but uses bit 0 for something else. Bit 0 is initially set to 1 in
+ # newUNOP(), but is later cleared (in ck_rvconst()), when the code
+ # notices that this op is an entersub.
+ #
+ # The important thing below is that any ops which use MAXARG at
+ # runtime must have all 4 bits allocated; if bit 3 were used for a new
+ # flag say, then things could break. The information on the other
+ # types of op is for completeness (so we can account for every bit
+ # used in every op)
+
+ my (%maxarg, %args0, %args1, %args2, %args3, %args4);
+
+ # these are the functions which currently use MAXARG at runtime
+ # (i.e. in the pp() functions). Thus they must always have 4 bits
+ # allocated
+ $maxarg{$_} = 1 for qw(
+ binmode bless caller chdir close enterwrite eof exit fileno getc
+ getpgrp gmtime index mkdir rand reset setpgrp sleep srand sysopen
+ tell umask
+ );
+
+ # find which ops use 0,1,2,3 or 4 bits of op_private for arg count info
+
+ $args0{$_} = 1 for qw(entersub); # UNOPs that usurp bit 0
+
+ $args1{$_} = 1 for (
+ qw(reverse), # ck_fun(), but most bits stolen
+ grep !$maxarg{$_} && !$args0{$_},
+ ops_with_flag('1'), # UNOP
+ ops_with_flag('%'), # BASEOP/UNOP
+ ops_with_flag('|'), # LOGOP
+ ops_with_flag('-'), # FILESTATOP
+ ops_with_flag('}'), # LOOPEXOP
+ );
+
+ $args2{$_} = 1 for (
+ qw(vec),
+ grep !$maxarg{$_} && !$args0{$_} && !$args1{$_},
+ ops_with_flag('2'), # BINOP
+ # this is a binop, but special-cased as a
+ # baseop in regen/opcodes
+ 'sassign',
+ );
+
+ $args3{$_} = 1 for grep !$maxarg{$_} && !$args0{$_}
+ && !$args1{$_} && !$args2{$_},
+ # substr starts off with 4 bits set in
+ # ck_fun(), but since it never has more than 7
+ # args, bit 3 is later stolen
+ qw(substr);
+
+ $args4{$_} = 1 for keys %maxarg,
+ grep !$args0{$_} && !$args1{$_}
+ && !$args2{$_} && !$args3{$_},
+ ops_with_check('ck_fun'),
+ # these other ck_*() functions call ck_fun()
+ ops_with_check('ck_exec'),
+ ops_with_check('ck_glob'),
+ ops_with_check('ck_index'),
+ ops_with_check('ck_join'),
+ ops_with_check('ck_lfun'),
+ ops_with_check('ck_open'),
+ ops_with_check('ck_select'),
+ ops_with_check('ck_tell'),
+ ops_with_check('ck_trunc'),
+ ;
+
+
+ for (sort keys %args1) {
+ addbits($_, '0..0' => {
+ mask_def => 'OPpARG1_MASK',
+ label => '-',
+ }
+ );
+ }
+
+ for (sort keys %args2) {
+ addbits($_, '0..1' => {
+ mask_def => 'OPpARG2_MASK',
+ label => '-',
+ }
+ );
+ }
+
+ for (sort keys %args3) {
+ addbits($_, '0..2' => {
+ mask_def => 'OPpARG3_MASK',
+ label => '-',
+ }
+ );
+ }
+
+ for (sort keys %args4) {
+ addbits($_, '0..3' => {
+ mask_def => 'OPpARG4_MASK',
+ label => '-',
+ }
+ );
+ }
+}
+
+
+
+# if NATIVE_HINTS is defined, op_private on cops holds the top 8 bits
+# of PL_hints, although only bits 6 & 7 are officially used for that
+# purpose (the rest ought to be masked off). Bit 5 is set separately
+
+for (qw(nextstate dbstate)) {
+ addbits($_,
+ 5 => qw(OPpHUSH_VMSISH HUSH),
+ # should match HINT_M_VMSISH_STATUS, HINT_M_VMSISH_TIME
+ 6 => qw(OPpHINT_M_VMSISH_STATUS VMSISH_STATUS),
+ 7 => qw(OPpHINT_M_VMSISH_TIME VMSISH_TIME),
+
+ );
+}
+
+
+
+addbits($_, 7 => qw(OPpLVAL_INTRO LVINTRO))
+ for qw(pos substr vec gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice
+ hslice delete padsv padav padhv enteriter entersub padrange
+ pushmark cond_expr),
+ 'list', # this gets set in my_attrs() for some reason
+ ;
+
+
+
+# TARGLEX
+#
+# in constructs like my $x; ...; $x = $a + $b,
+# the sassign is optimised away and OPpTARGET_MY is set on the add op
+#
+# Note that OPpTARGET_MY is mainly used at compile-time. At run time,
+# the pp function just updates the SV pointed to by op_targ, and doesn't
+# care whether that's a PADTMP or a lexical var.
+
+# Some comments about when its safe to use T/OPpTARGET_MY.
+#
+# Safe to set if the ppcode uses:
+# tryAMAGICbin, tryAMAGICun, SETn, SETi, SETu, PUSHn, PUSHTARG, SETTARG,
+# SETs(TARG), XPUSHn, XPUSHu,
+#
+# Unsafe to set if the ppcode uses dTARG or [X]RETPUSH[YES|NO|UNDEF]
+#
+# lt and friends do SETs (including ncmp, but not scmp)
+#
+# Additional mode of failure: the opcode can modify TARG before it "used"
+# all the arguments (or may call an external function which does the same).
+# If the target coincides with one of the arguments ==> kaboom.
+#
+# pp.c pos substr each not OK (RETPUSHUNDEF)
+# substr vec also not OK due to LV to target (are they???)
+# ref not OK (RETPUSHNO)
+# trans not OK (dTARG; TARG = sv_newmortal();)
+# ucfirst etc not OK: TMP arg processed inplace
+# quotemeta not OK (unsafe when TARG == arg)
+# each repeat not OK too due to list context
+# pack split - unknown whether they are safe
+# sprintf: is calling do_sprintf(TARG,...) which can act on TARG
+# before other args are processed.
+#
+# Suspicious wrt "additional mode of failure" (and only it):
+# schop, chop, postinc/dec, bit_and etc, negate, complement.
+#
+# Also suspicious: 4-arg substr, sprintf, uc/lc (POK_only), reverse, pack.
+#
+# substr/vec: doing TAINT_off()???
+#
+# pp_hot.c
+# readline - unknown whether it is safe
+# match subst not OK (dTARG)
+# grepwhile not OK (not always setting)
+# join not OK (unsafe when TARG == arg)
+#
+# Suspicious wrt "additional mode of failure": concat (dealt with
+# in ck_sassign()), join (same).
+#
+# pp_ctl.c
+# mapwhile flip caller not OK (not always setting)
+#
+# pp_sys.c
+# backtick glob warn die not OK (not always setting)
+# warn not OK (RETPUSHYES)
+# open fileno getc sysread syswrite ioctl accept shutdown
+# ftsize(etc) readlink telldir fork alarm getlogin not OK (RETPUSHUNDEF)
+# umask select not OK (XPUSHs(&PL_sv_undef);)
+# fileno getc sysread syswrite tell not OK (meth("FILENO" "GETC"))
+# sselect shm* sem* msg* syscall - unknown whether they are safe
+# gmtime not OK (list context)
+#
+# Suspicious wrt "additional mode of failure": warn, die, select.
+
+
+addbits($_, 4 => qw(OPpTARGET_MY TARGMY))
+ for ops_with_flag('T'),
+ # This flag is also used to indicate matches against implicit $_,
+ # where $_ is lexical; e.g. my $_; ....; /foo/
+ qw(match subst trans transr);
+;
+
+
+
+
+
+# op_targ carries a refcount
+addbits($_, 6 => qw(OPpREFCOUNTED REFC))
+ for qw(leave leavesub leavesublv leavewrite leaveeval);
+
+
+
+# Do not copy return value
+addbits($_, 7 => qw(OPpLVALUE LV)) for qw(leave leaveloop);
+
+
+
+# Pattern coming in on the stack
+addbits($_, 6 => qw(OPpRUNTIME RTIME))
+ for qw(match subst substcont qr pushre);
+
+
+
+# autovivify: Want ref to something
+for (qw(rv2gv rv2sv padsv aelem helem entersub)) {
+ addbits($_, '5..6' => {
+ mask_def => 'OPpDEREF',
+ enum => [ qw(
+ 1 OPpDEREF_AV DREFAV
+ 2 OPpDEREF_HV DREFHV
+ 3 OPpDEREF_SV DREFSV
+ )],
+ }
+ );
+}
+
+
+
+# Defer creation of array/hash elem
+addbits($_, 4 => qw(OPpLVAL_DEFER LVDEFER)) for qw(aelem helem);
+
+
+
+addbits($_, 2 => qw(OPpSLICEWARNING SLICEWARN)) # warn about @hash{$scalar}
+ for qw(rv2hv rv2av padav padhv hslice aslice);
+
+
+
+# XXX Concise seemed to think that OPpOUR_INTRO is used in rv2gv too,
+# but I can't see it - DAPM
+addbits($_, 4 => qw(OPpOUR_INTRO OURINTR)) # Variable was in an our()
+ for qw(gvsv rv2sv rv2av rv2hv enteriter);
+
+
+
+# We might be an lvalue to return
+addbits($_, 3 => qw(OPpMAYBE_LVSUB LVSUB))
+ for qw(aassign rv2av rv2gv rv2hv padav padhv aelem helem aslice hslice
+ av2arylen keys rkeys kvaslice kvhslice substr pos vec);
+
+
+
+for (qw(rv2hv padhv)) {
+ addbits($_, # e.g. %hash in (%hash || $foo) ...
+ 5 => qw(OPpTRUEBOOL BOOL), # ... in void cxt
+ 6 => qw(OPpMAYBE_TRUEBOOL BOOL?), # ... cx not known till run time
+ );
+}
+
+
+
+addbits($_, 1 => qw(OPpHINT_STRICT_REFS STRICT)) for qw(rv2sv rv2av rv2hv rv2gv);
+
+
+
+# Treat caller(1) as caller(2)
+addbits($_, 7 => qw(OPpOFFBYONE +1)) for qw(caller wantarray runcv);
+
+
+
+# label is in UTF8 */
+addbits($_, 7 => qw(OPpPV_IS_UTF8 UTF)) for qw(last redo next goto dump);
+
+
+
+# ====================================================================
+#
+# OP-SPECIFIC OPpFOO_* flags:
+#
+# where FOO is typically the name of an op, and the flag is used by a
+# single op (or maybe by a few closely related ops).
+
+
+
+addbits($_, 4 => qw(OPpPAD_STATE STATE)) for qw(padav padhv padsv pushmark);
+
+
+
+addbits('aassign', 6 => qw(OPpASSIGN_COMMON COMMON));
+
+
+
+addbits('sassign',
+ 6 => qw(OPpASSIGN_BACKWARDS BKWARD), # Left & right switched
+ 7 => qw(OPpASSIGN_CV_TO_GV CV2GV), # Possible optimisation for constants
+);
+
+
+
+for (qw(trans transr)) {
+ addbits($_,
+ 0 => qw(OPpTRANS_FROM_UTF <UTF),
+ 1 => qw(OPpTRANS_TO_UTF >UTF),
+ 2 => qw(OPpTRANS_IDENTICAL IDENT), # right side is same as left
+ 3 => qw(OPpTRANS_SQUASH SQUASH),
+ # 4 is used for OPpTARGET_MY
+ 5 => qw(OPpTRANS_COMPLEMENT COMPL),
+ 6 => qw(OPpTRANS_GROWS GROWS),
+ 7 => qw(OPpTRANS_DELETE DEL),
+ );
+}
+
+
+
+addbits('repeat', 6 => qw(OPpREPEAT_DOLIST DOLIST)); # List replication
+
+
+
+# OP_ENTERSUB and OP_RV2CV flags
+#
+# Flags are set on entersub and rv2cv in three phases:
+# parser - the parser passes the flag to the op constructor
+# check - the check routine called by the op constructor sets the flag
+# context - application of scalar/ref/lvalue context applies the flag
+#
+# In the third stage, an entersub op might turn into an rv2cv op (undef &foo,
+# \&foo, lock &foo, exists &foo, defined &foo). The two places where that
+# happens (op_lvalue_flags and doref in op.c) need to make sure the flags do
+# not conflict, since some flags with different meanings overlap between
+# the two ops. Flags applied in the context phase are only set when there
+# is no conversion of op type.
+#
+# bit entersub flag phase rv2cv flag phase
+# --- ------------- ----- ---------- -----
+# 0 OPpENTERSUB_INARGS context
+# 1 HINT_STRICT_REFS check HINT_STRICT_REFS check
+# 2 OPpENTERSUB_HASTARG checki OPpENTERSUB_HASTARG
+# 3 OPpENTERSUB_AMPER check OPpENTERSUB_AMPER parser
+# 4 OPpENTERSUB_DB check OPpENTERSUB_DB
+# 5 OPpDEREF_AV context
+# 6 OPpDEREF_HV context OPpMAY_RETURN_CONSTANT parser/context
+# 7 OPpLVAL_INTRO context OPpENTERSUB_NOPAREN parser
+
+# NB: OPpHINT_STRICT_REFS must equal HINT_STRICT_REFS
+
+addbits('entersub',
+ 0 => qw(OPpENTERSUB_INARGS INARGS), # Lval used as arg to a sub
+ 1 => qw(OPpHINT_STRICT_REFS STRICT), # 'use strict' in scope
+ 2 => qw(OPpENTERSUB_HASTARG TARG ), # Called from OP tree
+ 3 => qw(OPpENTERSUB_AMPER AMPER), # Used & form to call
+ 4 => qw(OPpENTERSUB_DB DBG ), # Debug subroutine
+ # 5..6 => OPpDEREF, already defined above
+ # 7 => OPpLVAL_INTRO, already defined above
+);
+
+# note that some of these flags are just left-over from when an entersub
+# is converted into an rv2cv, and could probably be cleared/re-assigned
+
+addbits('rv2cv',
+ 1 => qw(OPpHINT_STRICT_REFS STRICT), # 'use strict' in scope
+ 2 => qw(OPpENTERSUB_HASTARG TARG ), # If const sub, return the const
+ 3 => qw(OPpENTERSUB_AMPER AMPER ), # Used & form to call
+ 4 => qw(OPpENTERSUB_DB DBG ), # Debug subroutine
+
+ 6 => qw(OPpMAY_RETURN_CONSTANT CONST ),
+ 7 => qw(OPpENTERSUB_NOPAREN NO() ), # bare sub call (without parens)
+);
+
+
+
+#foo() called before sub foo was parsed */
+addbits('gv', 5 => qw(OPpEARLY_CV EARLYCV));
+
+
+
+# 1st arg is replacement string */
+addbits('substr', 4 => qw(OPpSUBSTR_REPL_FIRST REPL1ST));
+
+
+
+addbits('padrange',
+ # bits 0..6 hold target range
+ '0..6' => {
+ label => '-',
+ mask_def => 'OPpPADRANGE_COUNTMASK',
+ bitcount_def => 'OPpPADRANGE_COUNTSHIFT',
+ }
+ # 7 => OPpLVAL_INTRO, already defined above
+);
+
+
+
+for (qw(aelemfast aelemfast_lex)) {
+ addbits($_,
+ '0..7' => {
+ label => '-',
+ }
+ );
+}
+
+
+
+addbits('rv2gv',
+ 2 => qw(OPpDONT_INIT_GV NOINIT), # Call gv_fetchpv with GV_NOINIT
+ # (Therefore will return whatever is currently in
+ # the symbol table, not guaranteed to be a PVGV)
+ 4 => qw(OPpALLOW_FAKE FAKE), # OK to return fake glob
+);
+
+
+
+addbits('enteriter',
+ 2 => qw(OPpITER_REVERSED REVERSED),# for (reverse ...)
+ 3 => qw(OPpITER_DEF DEF), # 'for $_' or 'for my $_'
+);
+addbits('iter', 2 => qw(OPpITER_REVERSED REVERSED));
+
+
+
+addbits('const',
+ 1 => qw(OPpCONST_NOVER NOVER), # no 6;
+ 2 => qw(OPpCONST_SHORTCIRCUIT SHORT), # e.g. the constant 5 in (5 || foo)
+ 3 => qw(OPpCONST_STRICT STRICT), # bareword subject to strict 'subs'
+ 4 => qw(OPpCONST_ENTERED ENTERED), # Has been entered as symbol
+ 6 => qw(OPpCONST_BARE BARE), # Was a bare word (filehandle?)
+);
+
+
+
+# Range arg potentially a line num. */
+addbits($_, 6 => qw(OPpFLIP_LINENUM LINENUM)) for qw(flip flop);
+
+
+
+# Guessed that pushmark was needed. */
+addbits('list', 6 => qw(OPpLIST_GUESSED GUESSED));
+
+
+
+# Operating on a list of keys
+addbits('delete', 6 => qw(OPpSLICE SLICE));
+# also 7 => OPpLVAL_INTRO, already defined above
+
+
+
+# Checking for &sub, not {} or [].
+addbits('exists', 6 => qw(OPpEXISTS_SUB SUB));
+
+
+
+addbits('sort',
+ 0 => qw(OPpSORT_NUMERIC NUM ), # Optimized away { $a <=> $b }
+ 1 => qw(OPpSORT_INTEGER INT ), # Ditto while under "use integer"
+ 2 => qw(OPpSORT_REVERSE REV ), # Reversed sort
+ 3 => qw(OPpSORT_INPLACE INPLACE), # sort in-place; eg @a = sort @a
+ 4 => qw(OPpSORT_DESCEND DESC ), # Descending sort
+ 5 => qw(OPpSORT_QSORT QSORT ), # Use quicksort (not mergesort)
+ 6 => qw(OPpSORT_STABLE STABLE ), # Use a stable algorithm
+);
+
+
+
+# reverse in-place (@a = reverse @a) */
+addbits('reverse', 3 => qw(OPpREVERSE_INPLACE INPLACE));
+
+
+
+for (qw(open backtick)) {
+ addbits($_,
+ 4 => qw(OPpOPEN_IN_RAW INBIN ), # binmode(F,":raw") on input fh
+ 5 => qw(OPpOPEN_IN_CRLF INCR ), # binmode(F,":crlf") on input fh
+ 6 => qw(OPpOPEN_OUT_RAW OUTBIN), # binmode(F,":raw") on output fh
+ 7 => qw(OPpOPEN_OUT_CRLF OUTCR ), # binmode(F,":crlf") on output fh
+ );
+}
+
+
+
+# The various OPpFT* filetest ops
+
+# "use filetest 'access'" is in scope:
+# this flag is set only on a subset of the FT* ops
+addbits($_, 1 => qw(OPpFT_ACCESS FTACCESS)) for ops_with_arg(0, 'F-+');
+
+# all OPpFT* ops except stat and lstat
+for (grep { $_ !~ /^l?stat$/ } ops_with_flag('-')) {
+ addbits($_,
+ 2 => qw(OPpFT_STACKED FTSTACKED ), # stacked filetest,
+ # e.g. "-f" in "-f -x $foo"
+ 3 => qw(OPpFT_STACKING FTSTACKING), # stacking filetest.
+ # e.g. "-x" in "-f -x $foo"
+ 4 => qw(OPpFT_AFTER_t FTAFTERt ), # previous op was -t
+ );
+}
+
+
+
+addbits($_, 1 => qw(OPpGREP_LEX GREPLEX)) # iterate over lexical $_
+ for qw(mapwhile mapstart grepwhile grepstart);
+
+
+
+addbits('entereval',
+ 1 => qw(OPpEVAL_HAS_HH HAS_HH ), # Does it have a copy of %^H ?
+ 2 => qw(OPpEVAL_UNICODE UNI ),
+ 3 => qw(OPpEVAL_BYTES BYTES ),
+ 4 => qw(OPpEVAL_COPHH COPHH ), # Construct %^H from COP hints
+ 5 => qw(OPpEVAL_RE_REPARSING REPARSE), # eval_sv(..., G_RE_REPARSING)
+);
+
+
+
+# These must not conflict with OPpDONT_INIT_GV or OPpALLOW_FAKE.
+# See pp.c:S_rv2gv. */
+addbits('coreargs',
+ 0 => qw(OPpCOREARGS_DEREF1 DEREF1), # Arg 1 is a handle constructor
+ 1 => qw(OPpCOREARGS_DEREF2 DEREF2), # Arg 2 is a handle constructor
+ #2 reserved for OPpDONT_INIT_GV in rv2gv
+ #4 reserved for OPpALLOW_FAKE in rv2gv
+ 6 => qw(OPpCOREARGS_SCALARMOD $MOD ), # \$ rather than \[$@%*]
+ 7 => qw(OPpCOREARGS_PUSHMARK MARK ), # Call pp_pushmark
+);
+
+
+
+addbits('split', 7 => qw(OPpSPLIT_IMPLIM IMPLIM)); # implicit limit
+
+1;
+
+# ex: set ts=8 sts=4 sw=4 et:
# opcode.h
# opnames.h
# pp_proto.h
+# lib/B/Op_private.pm
#
-# from information stored in regen/opcodes, plus the
-# values hardcoded into this script in @raw_alias.
+# from:
+# * information stored in regen/opcodes;
+# * information stored in regen/op_private (which is actually perl code);
+# * the values hardcoded into this script in @raw_alias.
#
# Accepts the standard regen_lib -q and -v args.
#
{ by => 'regen/opcode.pl', from => 'its data', style => '*',
file => 'opnames.h', copyright => [1999 .. 2008] });
-# Read data.
+my $oprivpm = open_new('lib/B/Op_private.pm', '>',
+ { by => 'regen/opcode.pl',
+ from => "data in\nregen/op_private "
+ ."and pod embedded in regen/opcode.pl",
+ style => '#',
+ file => 'lib/B/Op_private.pm',
+ copyright => [2014 .. 2014] });
+
+# Read 'opcodes' data.
my %seen;
my (@ops, %desc, %check, %ckname, %flags, %args, %opnum);
$alias{$sock_func} = ["Perl_pp_$sock_func", '#ifdef HAS_SOCKET'],
}
+
+
+# =================================================================
+#
+# Functions for processing regen/op_private data.
+#
+# Put them in a separate package so that croak() does the right thing
+
+package OP_PRIVATE;
+
+use Carp;
+
+
+# the vars holding the global state built up by all the calls to addbits()
+
+
+# map OPpLVAL_INTRO => LVINTRO
+my %LABELS;
+
+
+# the numeric values of flags - what will get output as a #define
+my %DEFINES;
+
+# %BITFIELDS: the various bit field types. The key is the concatenation of
+# all the field values that make up a bit field hash; the values are bit
+# field hash refs. This allows us to de-dup identical bit field defs
+# across different ops, and thus make the output tables more compact (esp
+# important for the C version)
+my %BITFIELDS;
+
+# %FLAGS: the main data structure. Indexed by op name, then bit index:
+# single bit flag:
+# $FLAGS{rv2av}{2} = 'OPpSLICEWARNING';
+# bit field (bits 5 and 6):
+# $FLAGS{rv2av}{5} = $FLAGS{rv2av}{6} = { .... };
+my %FLAGS;
+
+
+# do, with checking, $LABELS{$name} = $label
+
+sub add_label {
+ my ($name, $label) = @_;
+ if (exists $LABELS{$name} and $LABELS{$name} ne $label) {
+ croak "addbits(): label for flag '$name' redefined:\n"
+ . " was '$LABELS{$name}', now '$label'";
+ }
+ $LABELS{$name} = $label;
+}
+
+#
+# do, with checking, $DEFINES{$name} = $val
+
+sub add_define {
+ my ($name, $val) = @_;
+ if (exists $DEFINES{$name} && $DEFINES{$name} != $val) {
+ croak "addbits(): value for flag '$name' redefined:\n"
+ . " was $DEFINES{$name}, now $val";
+ }
+ $DEFINES{$name} = $val;
+}
+
+
+# intended to be called from regen/op_private; see that file for details
+
+sub ::addbits {
+ my @args = @_;
+
+ croak "too few arguments for addbits()" unless @args >= 3;
+ my $op = shift @args;
+ croak "invalid op name: '$op'" unless exists $opnum{$op};
+
+ while (@args) {
+ my $bits = shift @args;
+ if ($bits =~ /^[0-7]$/) {
+ # single bit
+ croak "addbits(): too few arguments for single bit flag"
+ unless @args >= 2;
+ my $flag_name = shift @args;
+ my $flag_label = shift @args;
+ add_label($flag_name, $flag_label);
+ croak "addbits(): bit $bits of $op already specified"
+ if defined $FLAGS{$op}{$bits};
+ $FLAGS{$op}{$bits} = $flag_name;
+ add_define($flag_name, (1 << $bits));
+ }
+ elsif ($bits =~ /^([0-7])\.\.([0-7])$/) {
+ # bit range
+ my ($bitmin, $bitmax) = ($1,$2);
+
+ croak "addbits(): min bit > max bit in bit range '$bits'"
+ unless $bitmin <= $bitmax;
+ croak "addbits(): bit field argument missing"
+ unless @args >= 1;
+
+ my $arg_hash = shift @args;
+ croak "addbits(): arg to $bits must be a hash ref"
+ unless defined $arg_hash and ref($arg_hash) =~ /HASH/;
+
+ my %valid_keys;
+ @valid_keys{qw(baseshift_def bitcount_def mask_def label enum)} = ();
+ for (keys %$arg_hash) {
+ croak "addbits(): unrecognised bifield key: '$_'"
+ unless exists $valid_keys{$_};
+ }
+
+ my $bitmask = 0;
+ $bitmask += (1 << $_) for $bitmin..$bitmax;
+
+ my $enum_id ='';
+
+ if (defined $arg_hash->{enum}) {
+ my $enum = $arg_hash->{enum};
+ croak "addbits(): arg to enum must be an array ref"
+ unless defined $enum and ref($enum) =~ /ARRAY/;
+ croak "addbits(): enum list must be in triplets"
+ unless @$enum % 3 == 0;
+
+ my $max_id = (1 << ($bitmax - $bitmin + 1)) - 1;
+
+ my @e = @$enum;
+ while (@e) {
+ my $enum_ix = shift @e;
+ my $enum_name = shift @e;
+ my $enum_label = shift @e;
+ croak "addbits(): enum index must be a number: '$enum_ix'"
+ unless $enum_ix =~ /^\d+$/;
+ croak "addbits(): enum index too big: '$enum_ix'"
+ unless $enum_ix <= $max_id;
+ add_label($enum_name, $enum_label);
+ add_define($enum_name, $enum_ix << $bitmin);
+ $enum_id .= "($enum_ix:$enum_name:$enum_label)";
+ }
+ }
+
+ # id is a fingerprint of all the content of the bit field hash
+ my $id = join ':', map defined() ? $_ : "-undef-",
+ $bitmin, $bitmax,
+ $arg_hash->{label},
+ $arg_hash->{mask_def},
+ $arg_hash->{baseshift_def},
+ $arg_hash->{bitcount_def},
+ $enum_id;
+
+ unless (defined $BITFIELDS{$id}) {
+
+ if (defined $arg_hash->{mask_def}) {
+ add_define($arg_hash->{mask_def}, $bitmask);
+ }
+
+ if (defined $arg_hash->{baseshift_def}) {
+ add_define($arg_hash->{baseshift_def}, $bitmin);
+ }
+
+ if (defined $arg_hash->{bitcount_def}) {
+ add_define($arg_hash->{bitcount_def}, $bitmax-$bitmin+1);
+ }
+
+ # create deep copy
+
+ my $copy = {};
+ for (qw(baseshift_def bitcount_def mask_def label)) {
+ $copy->{$_} = $arg_hash->{$_} if defined $arg_hash->{$_};
+ }
+ if (defined $arg_hash->{enum}) {
+ $copy->{enum} = [ @{$arg_hash->{enum}} ];
+ }
+
+ # and add some extra fields
+
+ $copy->{bitmask} = $bitmask;
+ $copy->{bitmin} = $bitmin;
+ $copy->{bitmax} = $bitmax;
+
+ $BITFIELDS{$id} = $copy;
+ }
+
+ for my $bit ($bitmin..$bitmax) {
+ croak "addbits(): bit $bit of $op already specified"
+ if defined $FLAGS{$op}{$bit};
+ $FLAGS{$op}{$bit} = $BITFIELDS{$id};
+ }
+ }
+ else {
+ croak "addbits(): invalid bit specifier '$bits'";
+ }
+ }
+}
+
+
+# intended to be called from regen/op_private; see that file for details
+
+sub ::ops_with_flag {
+ my $flag = shift;
+ return grep $flags{$_} =~ /\Q$flag/, sort keys %flags;
+}
+
+
+# intended to be called from regen/op_private; see that file for details
+
+sub ::ops_with_check {
+ my $c = shift;
+ return grep $check{$_} eq $c, sort keys %check;
+}
+
+
+# intended to be called from regen/op_private; see that file for details
+
+sub ::ops_with_arg {
+ my ($i, $arg_type) = @_;
+ my @ops;
+ for my $op (sort keys %args) {
+ my @args = split(' ',$args{$op});
+ push @ops, $op if defined $args[$i] and $args[$i] eq $arg_type;
+ }
+ @ops;
+}
+
+
+# output '#define OPpLVAL_INTRO 0x80' etc
+
+sub print_defines {
+ my $fh = shift;
+
+ for (sort { $DEFINES{$a} <=> $DEFINES{$b} || $a cmp $b } keys %DEFINES) {
+ printf $fh "#define %-23s 0x%02x\n", $_, $DEFINES{$_};
+ }
+}
+
+
+# Generate the content of B::Op_private
+
+sub print_B_Op_private {
+ my $fh = shift;
+
+ my $header = <<'EOF';
+@=head1 NAME
+@
+@B::Op_private - OP op_private flag definitions
+@
+@=head1 SYNOPSIS
+@
+@ use B::Op_private;
+@
+@ # flag details for bit 7 of OP_AELEM's op_private:
+@ my $name = $B::Op_private::bits{aelem}{7}; # OPpLVAL_INTRO
+@ my $value = $B::Op_private::defines{$name}; # 128
+@ my $label = $B::Op_private::labels{$name}; # LVINTRO
+@
+@ # the bit field at bits 5..6 of OP_AELEM's op_private:
+@ my $bf = $B::Op_private::bits{aelem}{6};
+@ my $mask = $bf->{bitmask}; # etc
+@
+@=head1 DESCRIPTION
+@
+@This module provides three global hashes:
+@
+@ %B::Op_private::bits
+@ %B::Op_private::defines
+@ %B::Op_private::labels
+@
+@which contain information about the per-op meanings of the bits in the
+@op_private field.
+@
+@=head2 C<%bits>
+@
+@This is indexed by op name and then bit number (0..7). For single bit flags,
+@it returns the name of the define (if any) for that bit:
+@
+@ $B::Op_private::bits{aelem}{7} eq 'OPpLVAL_INTRO';
+@
+@For bit fields, it returns a hash ref containing details about the field.
+@The same reference will be returned for all bit positions that make
+@up the bit field; so for example these both return the same hash ref:
+@
+@ $bitfield = $B::Op_private::bits{aelem}{5};
+@ $bitfield = $B::Op_private::bits{aelem}{6};
+@
+@The general format of this hash ref is
+@
+@ {
+@ # The bit range and mask; these are always present.
+@ bitmin => 5,
+@ bitmax => 6,
+@ bitmask => 0x60,
+@
+@ # (The remaining keys are optional)
+@
+@ # The names of any defines that were requested:
+@ mask_def => 'OPpFOO_MASK',
+@ baseshift_def => 'OPpFOO_SHIFT',
+@ bitcount_def => 'OPpFOO_BITS',
+@
+@ # If present, Concise etc will display the value with a 'FOO='
+@ # prefix. If it equals '-', then Concise will treat the bit
+@ # field as raw bits and not try to interpret it.
+@ label => 'FOO',
+@
+@ # If present, specifies the names of some defines and the
+@ # display labels that are used to assign meaning to particu-
+@ # lar integer values within the bit field; e.g. 3 is dis-
+@ # played as 'C'.
+@ enum => [ qw(
+@ 1 OPpFOO_A A
+@ 2 OPpFOO_B B
+@ 3 OPpFOO_C C
+@ )],
+@
+@ };
+@
+@
+@=head2 C<%defines>
+@
+@This gives the value of every C<OPp> define, e.g.
+@
+@ $B::Op_private::defines{OPpLVAL_INTRO} == 128;
+@
+@=head2 C<%labels>
+@
+@This gives the short display label for each define, as used by C<B::Concise>
+@and C<perl -Dx>, e.g.
+@
+@ $B::Op_private::labels{OPpLVAL_INTRO} eq 'LVINTRO';
+@
+@If the label equals '-', then Concise will treat the bit as a raw bit and
+@not try to display it symbolically.
+@
+@=cut
+
+package B::Op_private;
+
+our %bits;
+
+EOF
+ # remove podcheck.t-defeating leading char
+ $header =~ s/^\@//gm;
+ print $fh $header;
+ my $v = (::perl_version())[3];
+ print $fh qq{\nour \$VERSION = "$v";\n\n};
+
+ # for each flag/bit combination, find the ops which use it
+ my %combos;
+ for my $op (sort keys %FLAGS) {
+ my $entry = $FLAGS{$op};
+ for my $bit (0..7) {
+ my $e = $entry->{$bit};
+ next unless defined $e;
+ next if ref $e; # bit field, not flag
+ push @{$combos{$e}{$bit}}, $op;
+ }
+ }
+
+ # dump flags used by multiple ops
+ for my $flag (sort keys %combos) {
+ for my $bit (sort keys %{$combos{$flag}}) {
+ my $ops = $combos{$flag}{$bit};
+ next unless @$ops > 1;
+ my @o = sort @$ops;
+ print $fh "\$bits{\$_}{$bit} = '$flag' for qw(@o);\n";
+ }
+ }
+
+ # dump bit field definitions
+
+ my %bitfield_ix;
+ {
+ my %bitfields;
+ # stringified-ref to ref mapping
+ $bitfields{$_} = $_ for values %BITFIELDS;
+ my $ix = -1;
+ my $s = "\nmy \@bf = (\n";
+ for my $bitfield_key (sort keys %BITFIELDS) {
+ my $bitfield = $BITFIELDS{$bitfield_key};
+ $ix++;
+ $bitfield_ix{$bitfield} = $ix;
+
+ $s .= " {\n";
+ for (qw(label mask_def baseshift_def bitcount_def)) {
+ next unless defined $bitfield->{$_};
+ $s .= sprintf " %-9s => '%s',\n",
+ $_, $bitfield->{$_};
+ }
+ for (qw(bitmin bitmax bitmask)) {
+ croak "panic" unless defined $bitfield->{$_};
+ $s .= sprintf " %-9s => %d,\n",
+ $_, $bitfield->{$_};
+ }
+ if (defined $bitfield->{enum}) {
+ $s .= " enum => [\n";
+ my @enum = @{$bitfield->{enum}};
+ while (@enum) {
+ my $i = shift @enum;
+ my $name = shift @enum;
+ my $label = shift @enum;
+ $s .= sprintf " %d, %-10s, %s,\n",
+ $i, "'$name'", "'$label'";
+ }
+ $s .= " ],\n";
+ }
+ $s .= " },\n";
+
+ }
+ $s .= ");\n";
+ print $fh "$s\n";
+ }
+
+ # dump bitfields and remaining labels
+
+ for my $op (sort keys %FLAGS) {
+ my @indices;
+ my @vals;
+ my $entry = $FLAGS{$op};
+ my $bit;
+
+ for ($bit = 7; $bit >= 0; $bit--) {
+ next unless defined $entry->{$bit};
+ my $e = $entry->{$bit};
+ if (ref $e) {
+ my $ix = $bitfield_ix{$e};
+ for (reverse $e->{bitmin}..$e->{bitmax}) {
+ push @indices, $_;
+ push @vals, "\$bf[$ix]";
+ }
+ $bit = $e->{bitmin};
+ }
+ else {
+ next if @{$combos{$e}{$bit}} > 1; # already output
+ push @indices, $bit;
+ push @vals, "'$e'";
+ }
+ }
+ if (@indices) {
+ my $s = '';
+ $s = '@{' if @indices > 1;
+ $s .= "\$bits{$op}";
+ $s .= '}' if @indices > 1;
+ $s .= '{' . join(',', @indices) . '} = ';
+ $s .= '(' if @indices > 1;
+ $s .= join ', ', @vals;
+ $s .= ')' if @indices > 1;
+ print $fh "$s;\n";
+ }
+ }
+
+ # populate %defines and %labels
+
+ print $fh "\n\nour %defines = (\n";
+ printf $fh " %-23s => %3d,\n", $_ , $DEFINES{$_} for sort keys %DEFINES;
+ print $fh ");\n\nour %labels = (\n";
+ printf $fh " %-23s => '%s',\n", $_ , $LABELS{$_} for sort keys %LABELS;
+ print $fh ");\n";
+
+}
+
+
+
+# output the contents of the assorted PL_op_private_*[] tables
+
+sub print_PL_op_private_tables {
+ my $fh = shift;
+
+ my $PL_op_private_labels = '';
+ my $PL_op_private_valid = '';
+ my $PL_op_private_bitdef_ix = '';
+ my $PL_op_private_bitdefs = '';
+ my $PL_op_private_bitfields = '';
+
+ my %label_ix;
+ my %bitfield_ix;
+
+ # generate $PL_op_private_labels
+
+ {
+ my %labs;
+ $labs{$_} = 1 for values %LABELS; # de-duplicate labels
+ # add in bit field labels
+ for (values %BITFIELDS) {
+ next unless defined $_->{label};
+ $labs{$_->{label}} = 1;
+ }
+
+ my $labels = '';
+ for my $lab (sort keys %labs) {
+ $label_ix{$lab} = length $labels;
+ $labels .= "$lab\0";
+ $PL_op_private_labels .=
+ " "
+ . join(',', map("'$_'", split //, $lab))
+ . ",'\\0',\n";
+ }
+ }
+
+
+ # generate PL_op_private_bitfields
+
+ {
+ my %bitfields;
+ # stringified-ref to ref mapping
+ $bitfields{$_} = $_ for values %BITFIELDS;
+
+ my $ix = 0;
+ for my $bitfield_key (sort keys %BITFIELDS) {
+ my $bf = $BITFIELDS{$bitfield_key};
+ $bitfield_ix{$bf} = $ix;
+
+ my @b;
+ push @b, $bf->{bitmin},
+ defined $bf->{label} ? $label_ix{$bf->{label}} : -1;
+ my $enum = $bf->{enum};
+ if (defined $enum) {
+ my @enum = @$enum;
+ while (@enum) {
+ my $i = shift @enum;
+ my $name = shift @enum;
+ my $label = shift @enum;
+ push @b, $i, $label_ix{$label};
+ }
+ }
+ push @b, -1; # terminate enum list
+
+ $PL_op_private_bitfields .= " " . join(', ', @b) .",\n";
+ $ix += @b;
+ }
+ }
+
+
+ # generate PL_op_private_bitdefs, PL_op_private_bitdef_ix
+
+ {
+ my $bitdef_count = 0;
+
+ my %not_seen = %FLAGS;
+
+ my $opnum = -1;
+ for my $op (sort { $opnum{$a} <=> $opnum{$b} } keys %opnum) {
+ $opnum++;
+ die "panic: opnum misorder: opnum=$opnum opnum{op}=$opnum{$op}"
+ unless $opnum == $opnum{$op};
+ delete $not_seen{$op};
+
+ my @bitdefs;
+ my $entry = $FLAGS{$op};
+ my $bit;
+ my $index;
+
+ for ($bit = 7; $bit >= 0; $bit--) {
+ my $e = $entry->{$bit};
+ next unless defined $e;
+
+ my $ix;
+ if (ref $e) {
+ $ix = $bitfield_ix{$e};
+ die "panic: \$bit =\= $e->{bitmax}"
+ unless $bit == $e->{bitmax};
+
+ push @bitdefs, ( ($ix << 5) | ($bit << 2) | 2 );
+ $bit = $e->{bitmin};
+ }
+ else {
+ $ix = $label_ix{$LABELS{$e}};
+ die "panic: no label ix for '$e'" unless defined $ix;
+ push @bitdefs, ( ($ix << 5) | ($bit << 2));
+ }
+ if ($ix > 2047) {
+ die "Too many labels or bitfields (ix=$ix): "
+ . "maybe the type of PL_op_private_bitdefs needs "
+ . "expanding from U16 to U32???";
+ }
+ }
+ if (@bitdefs) {
+ $bitdefs[-1] |= 1; # stop bit
+ $index = $bitdef_count;
+ $bitdef_count += @bitdefs;
+ $PL_op_private_bitdefs .= sprintf " /* %-13s */ %s,\n",
+ $op,
+ join(', ', map(sprintf("0x%04x", $_), @bitdefs));
+ }
+ else {
+ $index = -1;
+ }
+ $PL_op_private_bitdef_ix .= sprintf " %4d, /* %s */\n", $index, $op;
+ }
+ if (%not_seen) {
+ die "panic: unprocessed ops: ". join(',', keys %not_seen);
+ }
+ }
+
+
+ # generate PL_op_private_valid
+
+ for my $op (@ops) {
+ my $last;
+ my @flags;
+ for my $bit (0..7) {
+ next unless exists $FLAGS{$op};
+ my $entry = $FLAGS{$op}{$bit};
+ next unless defined $entry;
+ if (ref $entry) {
+ # skip later entries for the same bit field
+ next if defined $last and $last == $entry;
+ $last = $entry;
+ push @flags,
+ defined $entry->{mask_def}
+ ? $entry->{mask_def}
+ : $entry->{bitmask};
+ }
+ else {
+ push @flags, $entry;
+ }
+ }
+
+ # all bets are off
+ @flags = '0xff' if $op eq 'null' or $op eq 'custom';
+
+ $PL_op_private_valid .= sprintf " /* %-10s */ (%s),\n", uc($op),
+ @flags ? join('|', @flags): '0';
+ }
+
+ print $fh <<EOF;
+START_EXTERN_C
+
+#ifndef PERL_GLOBAL_STRUCT_INIT
+
+# ifndef DOINIT
+
+/* data about the flags in op_private */
+
+EXTCONST I16 PL_op_private_bitdef_ix[];
+EXTCONST U16 PL_op_private_bitdefs[];
+EXTCONST char PL_op_private_labels[];
+EXTCONST I16 PL_op_private_bitfields[];
+EXTCONST U8 PL_op_private_valid[];
+
+# else
+
+
+/* PL_op_private_labels[]: the short descriptions of private flags.
+ * All labels are concatenated into a single char array
+ * (separated by \\0's) for compactness.
+ */
+
+EXTCONST char PL_op_private_labels[] = {
+$PL_op_private_labels
+};
+
+
+
+/* PL_op_private_bitfields[]: details about each bit field type.
+ * Each defintition consists of the following list of words:
+ * bitmin
+ * label (index into PL_op_private_labels[]; -1 if no label)
+ * repeat for each enum entry (if any):
+ * enum value
+ * enum label (index into PL_op_private_labels[])
+ * -1
+ */
+
+EXTCONST I16 PL_op_private_bitfields[] = {
+$PL_op_private_bitfields
+};
+
+
+/* PL_op_private_bitdef_ix[]: map an op number to a starting position
+ * in PL_op_private_bitdefs. If -1, the op has no bits defined */
+
+EXTCONST I16 PL_op_private_bitdef_ix[] = {
+$PL_op_private_bitdef_ix
+};
+
+
+
+/* PL_op_private_bitdefs[]: given a starting position in this array (as
+ * supplied by PL_op_private_bitdef_ix[]), each word (until a stop bit is
+ * seen) defines the meaning of a particular op_private bit for a
+ * particular op. Each word consists of:
+ * bit 0: stop bit: this is the last bit def for the current op
+ * bit 1: bitfield: if set, this defines a bit field rather than a flag
+ * bits 2..4: unsigned number in the range 0..7 which is the bit number
+ * bits 5..15: unsigned number in the range 0..2047 which is an index
+ * into PL_op_private_labels[] (for a flag), or
+ * into PL_op_private_bitfields[] (for a bit field)
+ */
+
+EXTCONST U16 PL_op_private_bitdefs[] = {
+$PL_op_private_bitdefs
+};
+
+
+/* PL_op_private_valid: for each op, indexed by op_type, indicate which
+ * flags bits in op_private are legal */
+
+EXTCONST U8 PL_op_private_valid[] = {
+$PL_op_private_valid
+};
+
+# endif /* !DOINIT */
+#endif /* !PERL_GLOBAL_STRUCT_INIT */
+
+END_EXTERN_C
+
+
+EOF
+
+}
+
+
+# =================================================================
+
+
+package main;
+
+# read regen/op_private data
+#
+# This file contains Perl code that builds up some data structures
+# which define what bits in op_private have what meanings for each op.
+# It populates %LABELS, %DEFINES, %FLAGS, %BITFIELDS.
+
+require 'regen/op_private';
+
+#use Data::Dumper;
+#print Dumper \%LABELS, \%DEFINES, \%FLAGS, \%BITFIELDS;
+
+
# Emit defines.
print $oc "#ifndef PERL_GLOBAL_STRUCT_INIT\n\n";
}
print $pp "PERL_CALLCONV OP *$_(pTHX);\n" foreach sort keys %funcs;
}
-foreach ($oc, $on, $pp) {
- read_only_bottom_close_and_rename($_);
-}
-
-# Some comments about 'T' opcode classifier:
-
-# Safe to set if the ppcode uses:
-# tryAMAGICbin, tryAMAGICun, SETn, SETi, SETu, PUSHn, PUSHTARG, SETTARG,
-# SETs(TARG), XPUSHn, XPUSHu,
-
-# Unsafe to set if the ppcode uses dTARG or [X]RETPUSH[YES|NO|UNDEF]
-# lt and friends do SETs (including ncmp, but not scmp)
+print $oc "\n\n";
+OP_PRIVATE::print_defines($oc);
+OP_PRIVATE::print_PL_op_private_tables($oc);
-# Additional mode of failure: the opcode can modify TARG before it "used"
-# all the arguments (or may call an external function which does the same).
-# If the target coincides with one of the arguments ==> kaboom.
+OP_PRIVATE::print_B_Op_private($oprivpm);
-# pp.c pos substr each not OK (RETPUSHUNDEF)
-# substr vec also not OK due to LV to target (are they???)
-# ref not OK (RETPUSHNO)
-# trans not OK (dTARG; TARG = sv_newmortal();)
-# ucfirst etc not OK: TMP arg processed inplace
-# quotemeta not OK (unsafe when TARG == arg)
-# each repeat not OK too due to list context
-# pack split - unknown whether they are safe
-# sprintf: is calling do_sprintf(TARG,...) which can act on TARG
-# before other args are processed.
-
-# Suspicious wrt "additional mode of failure" (and only it):
-# schop, chop, postinc/dec, bit_and etc, negate, complement.
-
-# Also suspicious: 4-arg substr, sprintf, uc/lc (POK_only), reverse, pack.
-
-# substr/vec: doing TAINT_off()???
-
-# pp_hot.c
-# readline - unknown whether it is safe
-# match subst not OK (dTARG)
-# grepwhile not OK (not always setting)
-# join not OK (unsafe when TARG == arg)
-
-# Suspicious wrt "additional mode of failure": concat (dealt with
-# in ck_sassign()), join (same).
-
-# pp_ctl.c
-# mapwhile flip caller not OK (not always setting)
-
-# pp_sys.c
-# backtick glob warn die not OK (not always setting)
-# warn not OK (RETPUSHYES)
-# open fileno getc sysread syswrite ioctl accept shutdown
-# ftsize(etc) readlink telldir fork alarm getlogin not OK (RETPUSHUNDEF)
-# umask select not OK (XPUSHs(&PL_sv_undef);)
-# fileno getc sysread syswrite tell not OK (meth("FILENO" "GETC"))
-# sselect shm* sem* msg* syscall - unknown whether they are safe
-# gmtime not OK (list context)
+foreach ($oc, $on, $pp, $oprivpm) {
+ read_only_bottom_close_and_rename($_);
+}
-# Suspicious wrt "additional mode of failure": warn, die, select.
# pvop/svop - " cop - ;
# Other options are:
-# needs stack mark - m
-# needs constant folding - f
-# produces a scalar - s
-# produces an integer - i
-# needs a target - t
-# target can be in a pad - T
-# has a corresponding integer version - I
-# has side effects - d
-# uses $_ if no argument given - u
+# needs stack mark - m (OA_MARK)
+# needs constant folding - f (OA_FOLDCONST)
+# produces a scalar - s (OA_RETSCALAR)
+# produces an integer - i (unused)
+# needs a target - t (OA_TARGET)
+# target can be in a pad - T (OA_TARGET|OA_TARGLEX)
+# has a corresponding integer version - I (OA_OTHERINT)
+# has side effects - d (OA_DANGEROUS)
+# uses $_ if no argument given - u (OA_DEFGV)
# Values for the operands are:
# scalar - S list - L array - A
my $ind = 0;
my (@name,@rest,@type,@code,@args,@flags,@longj,@cmnt);
my ($longest_name_length,$desc,$lastregop) = 0;
+my (%seen_op, %type_alias);
while (<DESC>) {
# Special pod comments
if (/^#\* ?/) { $cmnt[$ind] .= "# $'"; }
}
unless ($lastregop) {
($name[$ind], $desc, $rest[$ind]) = /^(\S+)\s+([^\t]+?)\s*;\s*(.*)/;
+
+ if (defined $seen_op{$name[$ind]}) {
+ die "Duplicate regop $name[$ind] in regcomp.sym line $. previously defined on line $seen_op{$name[$ind]}\n";
+ } else {
+ $seen_op{$name[$ind]}= $.;
+ }
+
($type[$ind], $code[$ind], $args[$ind], $flags[$ind], $longj[$ind])
= split /[,\s]\s*/, $desc;
+
+ if (!defined $seen_op{$type[$ind]} and !defined $type_alias{$type[$ind]}) {
+ #warn "Regop type '$type[$ind]' from regcomp.sym line $. is not an existing regop, and will be aliased to $name[$ind]\n"
+ # if -t STDERR;
+ $type_alias{$type[$ind]}= $name[$ind];
+ }
+
$longest_name_length = length $name[$ind]
if length $name[$ind] > $longest_name_length;
++$ind;
-$width, REGMATCH_STATE_MAX => $tot - 1
;
-
+my %rev_type_alias= reverse %type_alias;
for ($ind=0; $ind < $lastregop ; ++$ind) {
printf $out "#define\t%*s\t%d\t/* %#04x %s */\n",
-$width, $name[$ind], $ind, $ind, $rest[$ind];
+ if (defined(my $alias= $rev_type_alias{$name[$ind]})) {
+ printf $out "#define\t%*s\t%d\t/* %#04x %s */\n",
+ -$width, $alias, $ind, $ind, "type alias";
+ }
+
}
print $out "\t/* ------------ States ------------- */\n";
for ( ; $ind < $tot ; $ind++) {
Text::Wrap::wrap(@_);
}
+# return the perl version as defined in patchlevel.h.
+# (we may be being run by another perl, so $] won't be right)
+# return e.g. (5, 14, 3, "5.014003")
+
+sub perl_version {
+ my $plh = 'patchlevel.h';
+ open my $fh, "<", $plh or die "can't open '$plh': $!\n";
+ my ($v1,$v2,$v3);
+ while (<$fh>) {
+ $v1 = $1 if /PERL_REVISION\s+(\d+)/;
+ $v2 = $1 if /PERL_VERSION\s+(\d+)/;
+ $v3 = $1 if /PERL_SUBVERSION\s+(\d+)/;
+ }
+ die "can't locate PERL_REVISION in '$plh'" unless defined $v1;
+ die "can't locate PERL_VERSION in '$plh'" unless defined $v2;
+ die "can't locate PERL_SUBVERSION in '$plh'" unless defined $v3;
+ return ($v1,$v2,$v3, sprintf("%d.%03d%03d", $v1, $v2, $v3));
+}
+
+
1;
}
printf $out_fh "# define %s%s %s /* U+%04X */\n", $name, $suffix, $str, $U_cp;
}
+
+ my $max_PRINT_A = 0;
+ for my $i (0x20 .. 0x7E) {
+ $max_PRINT_A = $a2n[$i] if $a2n[$i] > $max_PRINT_A;
+ }
+ printf $out_fh "# define MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C 0x%02X /* The max code point that isPRINT_A */\n", $max_PRINT_A;
+
print $out_fh "\n" . get_conditional_compile_line_end();
}
DEL native
CR native
LF native
+VT native
+ESC native
U+00DF native
U+00E5 native
U+00C5 native
* be too fiddly (e.g. REXEC_IGNOREPOS).
*/
if ( strpos != strbeg
- && (prog->intflags & (PREGf_ANCH_BOL|PREGf_ANCH_SBOL)))
+ && (prog->intflags & PREGf_ANCH_SBOL))
{
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
" Not at start...\n"));
/* If the regex is absolutely anchored to either the start of the
- * string (BOL,SBOL) or to pos() (ANCH_GPOS), then
+ * string (SBOL) or to pos() (ANCH_GPOS), then
* check_offset_max represents an upper bound on the string where
* the substr could start. For the ANCH_GPOS case, we assume that
* the caller of intuit will have already set strpos to
magic belonging to this SV.
Not newSVsv, either, as it does not COW.
*/
- assert(!IS_PADGV(sv));
reginfo->sv = newSV(0);
SvSetSV_nosteal(reginfo->sv, sv);
SAVEFREESV(reginfo->sv);
}
/* Simplest case: anchored match need be tried only once. */
- /* [unless only anchor is BOL and multiline is set] */
+ /* [unless only anchor is MBOL - implying multiline is set] */
if (prog->intflags & (PREGf_ANCH & ~PREGf_ANCH_GPOS)) {
if (s == startpos && regtry(reginfo, &s))
goto got_it;
assert(nextchr < 256 && (nextchr >= 0 || nextchr == NEXTCHR_EOS));
switch (state_num) {
- case BOL: /* /^../ */
- case SBOL: /* /^../s */
+ case SBOL: /* /^../ and /\A../ */
if (locinput == reginfo->strbeg)
break;
sayNO;
sayNO;
break;
- case EOL: /* /..$/ */
- /* FALLTHROUGH */
- case SEOL: /* /..$/s */
+ case SEOL: /* /..$/ */
if (!NEXTCHR_IS_EOS && nextchr != '\n')
sayNO;
if (reginfo->strend - locinput > 1)
*altsvp = NULL;
}
- return newSVsv(_get_regclass_nonbitmap_data(prog, node, doinit, listsvp, NULL));
+ return newSVsv(_get_regclass_nonbitmap_data(prog, node, doinit, listsvp, NULL, NULL));
}
-SV *
-Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
- const regnode* node,
- bool doinit,
- SV** listsvp,
- SV** only_utf8_locale_ptr)
-{
- /* For internal core use only.
- * Returns the swash for the input 'node' in the regex 'prog'.
- * If <doinit> is 'true', will attempt to create the swash if not already
- * done.
- * If <listsvp> is non-null, will return the printable contents of the
- * swash. This can be used to get debugging information even before the
- * swash exists, by calling this function with 'doinit' set to false, in
- * which case the components that will be used to eventually create the
- * swash are returned (in a printable form).
- * Tied intimately to how regcomp.c sets up the data structure */
-
- SV *sw = NULL;
- SV *si = NULL; /* Input swash initialization string */
- SV* invlist = NULL;
-
- RXi_GET_DECL(prog,progi);
- const struct reg_data * const data = prog ? progi->data : NULL;
-
- PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
-
- assert(ANYOF_FLAGS(node)
- & (ANYOF_UTF8|ANYOF_NONBITMAP_NON_UTF8|ANYOF_LOC_FOLD));
-
- if (data && data->count) {
- const U32 n = ARG(node);
-
- if (data->what[n] == 's') {
- SV * const rv = MUTABLE_SV(data->data[n]);
- AV * const av = MUTABLE_AV(SvRV(rv));
- SV **const ary = AvARRAY(av);
- U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
-
- si = *ary; /* ary[0] = the string to initialize the swash with */
-
- /* Elements 3 and 4 are either both present or both absent. [3] is
- * any inversion list generated at compile time; [4] indicates if
- * that inversion list has any user-defined properties in it. */
- if (av_tindex(av) >= 2) {
- if (only_utf8_locale_ptr
- && ary[2]
- && ary[2] != &PL_sv_undef)
- {
- *only_utf8_locale_ptr = ary[2];
- }
- else {
- assert(only_utf8_locale_ptr);
- *only_utf8_locale_ptr = NULL;
- }
-
- if (av_tindex(av) >= 3) {
- invlist = ary[3];
- if (SvUV(ary[4])) {
- swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
- }
- }
- else {
- invlist = NULL;
- }
- }
-
- /* Element [1] is reserved for the set-up swash. If already there,
- * return it; if not, create it and store it there */
- if (ary[1] && SvROK(ary[1])) {
- sw = ary[1];
- }
- else if (doinit && ((si && si != &PL_sv_undef)
- || (invlist && invlist != &PL_sv_undef))) {
- assert(si);
- sw = _core_swash_init("utf8", /* the utf8 package */
- "", /* nameless */
- si,
- 1, /* binary */
- 0, /* not from tr/// */
- invlist,
- &swash_init_flags);
- (void)av_store(av, 1, sw);
- }
- }
- }
-
- /* If requested, return a printable version of what this swash matches */
- if (listsvp) {
- SV* matches_string = newSVpvs("");
-
- /* The swash should be used, if possible, to get the data, as it
- * contains the resolved data. But this function can be called at
- * compile-time, before everything gets resolved, in which case we
- * return the currently best available information, which is the string
- * that will eventually be used to do that resolving, 'si' */
- if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
- && (si && si != &PL_sv_undef))
- {
- sv_catsv(matches_string, si);
- }
-
- /* Add the inversion list to whatever we have. This may have come from
- * the swash, or from an input parameter */
- if (invlist) {
- sv_catsv(matches_string, _invlist_contents(invlist));
- }
- *listsvp = matches_string;
- }
-
- return sw;
-}
#endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
/*
}
/* If this character is potentially in the bitmap, check it */
- if (c < 256) {
+ if (c < NUM_ANYOF_CODE_POINTS) {
if (ANYOF_BITMAP_TEST(n, c))
match = TRUE;
- else if (flags & ANYOF_NON_UTF8_NON_ASCII_ALL
- && ! utf8_target
- && ! isASCII(c))
+ else if ((flags & ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII)
+ && ! utf8_target
+ && ! isASCII(c))
{
match = TRUE;
}
else if (flags & ANYOF_LOCALE_FLAGS) {
- if (flags & ANYOF_LOC_FOLD) {
- if (ANYOF_BITMAP_TEST(n, PL_fold_locale[c])) {
- match = TRUE;
- }
+ if ((flags & ANYOF_LOC_FOLD)
+ && c < 256
+ && ANYOF_BITMAP_TEST(n, PL_fold_locale[c]))
+ {
+ match = TRUE;
}
- if (! match && ANYOF_POSIXL_TEST_ANY_SET(n)) {
+ else if (ANYOF_POSIXL_TEST_ANY_SET(n)
+ && c < 256
+ ) {
/* The data structure is arranged so bits 0, 2, 4, ... are set
* if the class includes the Posix character class given by
/* If the bitmap didn't (or couldn't) match, and something outside the
* bitmap could match, try that. */
if (!match) {
- if (c >= 256 && (flags & ANYOF_ABOVE_LATIN1_ALL)) {
- match = TRUE; /* Everything above 255 matches */
+ if (c >= NUM_ANYOF_CODE_POINTS
+ && (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP))
+ {
+ match = TRUE; /* Everything above the bitmap matches */
}
- else if ((flags & ANYOF_NONBITMAP_NON_UTF8)
- || (utf8_target && (flags & ANYOF_UTF8))
+ else if ((flags & ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES)
+ || (utf8_target && (flags & ANYOF_HAS_UTF8_NONBITMAP_MATCHES))
|| ((flags & ANYOF_LOC_FOLD)
&& IN_UTF8_CTYPE_LOCALE
- && ARG(n) != ANYOF_NONBITMAP_EMPTY))
+ && ARG(n) != ANYOF_ONLY_HAS_BITMAP))
{
SV* only_utf8_locale = NULL;
SV * const sw = _get_regclass_nonbitmap_data(prog, n, TRUE, 0,
- &only_utf8_locale);
+ &only_utf8_locale, NULL);
if (sw) {
U8 utf8_buffer[2];
U8 * utf8_p;
/* Regops and State definitions */
-#define REGNODE_MAX 93
-#define REGMATCH_STATE_MAX 133
+#define REGNODE_MAX 91
+#define REGMATCH_STATE_MAX 131
#define END 0 /* 0000 End of program. */
#define SUCCEED 1 /* 0x01 Return from a subroutine, basically. */
-#define BOL 2 /* 0x02 Match "" at beginning of line. */
-#define MBOL 3 /* 0x03 Same, assuming multiline. */
-#define SBOL 4 /* 0x04 Same, assuming singleline. */
-#define EOS 5 /* 0x05 Match "" at end of string. */
-#define EOL 6 /* 0x06 Match "" at end of line. */
-#define MEOL 7 /* 0x07 Same, assuming multiline. */
-#define SEOL 8 /* 0x08 Same, assuming singleline. */
-#define BOUND 9 /* 0x09 Match "" at any word boundary using native charset rules for non-utf8 */
-#define BOUNDL 10 /* 0x0a Match "" at any locale word boundary */
-#define BOUNDU 11 /* 0x0b Match "" at any word boundary using Unicode rules */
-#define BOUNDA 12 /* 0x0c Match "" at any word boundary using ASCII rules */
-#define NBOUND 13 /* 0x0d Match "" at any word non-boundary using native charset rules for non-utf8 */
-#define NBOUNDL 14 /* 0x0e Match "" at any locale word non-boundary */
-#define NBOUNDU 15 /* 0x0f Match "" at any word non-boundary using Unicode rules */
-#define NBOUNDA 16 /* 0x10 Match "" at any word non-boundary using ASCII rules */
-#define GPOS 17 /* 0x11 Matches where last m//g left off. */
-#define REG_ANY 18 /* 0x12 Match any one character (except newline). */
-#define SANY 19 /* 0x13 Match any one character. */
-#define CANY 20 /* 0x14 Match any one byte. */
-#define ANYOF 21 /* 0x15 Match character in (or not in) this class, single char match only */
-#define POSIXD 22 /* 0x16 Some [[:class:]] under /d; the FLAGS field gives which one */
-#define POSIXL 23 /* 0x17 Some [[:class:]] under /l; the FLAGS field gives which one */
-#define POSIXU 24 /* 0x18 Some [[:class:]] under /u; the FLAGS field gives which one */
-#define POSIXA 25 /* 0x19 Some [[:class:]] under /a; the FLAGS field gives which one */
-#define NPOSIXD 26 /* 0x1a complement of POSIXD, [[:^class:]] */
-#define NPOSIXL 27 /* 0x1b complement of POSIXL, [[:^class:]] */
-#define NPOSIXU 28 /* 0x1c complement of POSIXU, [[:^class:]] */
-#define NPOSIXA 29 /* 0x1d complement of POSIXA, [[:^class:]] */
-#define CLUMP 30 /* 0x1e Match any extended grapheme cluster sequence */
-#define BRANCH 31 /* 0x1f Match this alternative, or the next... */
-#define BACK 32 /* 0x20 Match "", "next" ptr points backward. */
-#define EXACT 33 /* 0x21 Match this string (preceded by length). */
-#define EXACTF 34 /* 0x22 Match this non-UTF-8 string (not guaranteed to be folded) using /id rules (w/len). */
-#define EXACTFL 35 /* 0x23 Match this string (not guaranteed to be folded) using /il rules (w/len). */
-#define EXACTFU 36 /* 0x24 Match this string (folded iff in UTF-8, length in folding doesn't change if not in UTF-8) using /iu rules (w/len). */
-#define EXACTFA 37 /* 0x25 Match this string (not guaranteed to be folded) using /iaa rules (w/len). */
-#define EXACTFU_SS 38 /* 0x26 Match this string (folded iff in UTF-8, length in folding may change even if not in UTF-8) using /iu rules (w/len). */
-#define EXACTFA_NO_TRIE 39 /* 0x27 Match this string (which is not trie-able; not guaranteed to be folded) using /iaa rules (w/len). */
-#define NOTHING 40 /* 0x28 Match empty string. */
-#define TAIL 41 /* 0x29 Match empty string. Can jump here from outside. */
-#define STAR 42 /* 0x2a Match this (simple) thing 0 or more times. */
-#define PLUS 43 /* 0x2b Match this (simple) thing 1 or more times. */
-#define CURLY 44 /* 0x2c Match this simple thing {n,m} times. */
-#define CURLYN 45 /* 0x2d Capture next-after-this simple thing */
-#define CURLYM 46 /* 0x2e Capture this medium-complex thing {n,m} times. */
-#define CURLYX 47 /* 0x2f Match this complex thing {n,m} times. */
-#define WHILEM 48 /* 0x30 Do curly processing and see if rest matches. */
-#define OPEN 49 /* 0x31 Mark this point in input as start of #n. */
-#define CLOSE 50 /* 0x32 Analogous to OPEN. */
-#define REF 51 /* 0x33 Match some already matched string */
-#define REFF 52 /* 0x34 Match already matched string, folded using native charset rules for non-utf8 */
-#define REFFL 53 /* 0x35 Match already matched string, folded in loc. */
-#define REFFU 54 /* 0x36 Match already matched string, folded using unicode rules for non-utf8 */
-#define REFFA 55 /* 0x37 Match already matched string, folded using unicode rules for non-utf8, no mixing ASCII, non-ASCII */
-#define NREF 56 /* 0x38 Match some already matched string */
-#define NREFF 57 /* 0x39 Match already matched string, folded using native charset rules for non-utf8 */
-#define NREFFL 58 /* 0x3a Match already matched string, folded in loc. */
-#define NREFFU 59 /* 0x3b Match already matched string, folded using unicode rules for non-utf8 */
-#define NREFFA 60 /* 0x3c Match already matched string, folded using unicode rules for non-utf8, no mixing ASCII, non-ASCII */
+#define SBOL 2 /* 0x02 Match "" at beginning of line: /^/, /\A/ */
+#define BOL 2 /* 0x02 type alias */
+#define MBOL 3 /* 0x03 Same, assuming multiline: /^/m */
+#define SEOL 4 /* 0x04 Match "" at end of line: /$/ */
+#define EOL 4 /* 0x04 type alias */
+#define MEOL 5 /* 0x05 Same, assuming multiline: /$/m */
+#define EOS 6 /* 0x06 Match "" at end of string: /\z/ */
+#define GPOS 7 /* 0x07 Matches where last m//g left off. */
+#define BOUND 8 /* 0x08 Match "" at any word boundary using native charset rules for non-utf8 */
+#define BOUNDL 9 /* 0x09 Match "" at any locale word boundary */
+#define BOUNDU 10 /* 0x0a Match "" at any word boundary using Unicode rules */
+#define BOUNDA 11 /* 0x0b Match "" at any word boundary using ASCII rules */
+#define NBOUND 12 /* 0x0c Match "" at any word non-boundary using native charset rules for non-utf8 */
+#define NBOUNDL 13 /* 0x0d Match "" at any locale word non-boundary */
+#define NBOUNDU 14 /* 0x0e Match "" at any word non-boundary using Unicode rules */
+#define NBOUNDA 15 /* 0x0f Match "" at any word non-boundary using ASCII rules */
+#define REG_ANY 16 /* 0x10 Match any one character (except newline). */
+#define SANY 17 /* 0x11 Match any one character. */
+#define CANY 18 /* 0x12 Match any one byte. */
+#define ANYOF 19 /* 0x13 Match character in (or not in) this class, single char match only */
+#define POSIXD 20 /* 0x14 Some [[:class:]] under /d; the FLAGS field gives which one */
+#define POSIXL 21 /* 0x15 Some [[:class:]] under /l; the FLAGS field gives which one */
+#define POSIXU 22 /* 0x16 Some [[:class:]] under /u; the FLAGS field gives which one */
+#define POSIXA 23 /* 0x17 Some [[:class:]] under /a; the FLAGS field gives which one */
+#define NPOSIXD 24 /* 0x18 complement of POSIXD, [[:^class:]] */
+#define NPOSIXL 25 /* 0x19 complement of POSIXL, [[:^class:]] */
+#define NPOSIXU 26 /* 0x1a complement of POSIXU, [[:^class:]] */
+#define NPOSIXA 27 /* 0x1b complement of POSIXA, [[:^class:]] */
+#define CLUMP 28 /* 0x1c Match any extended grapheme cluster sequence */
+#define BRANCH 29 /* 0x1d Match this alternative, or the next... */
+#define BACK 30 /* 0x1e Match "", "next" ptr points backward. */
+#define EXACT 31 /* 0x1f Match this string (preceded by length). */
+#define EXACTF 32 /* 0x20 Match this non-UTF-8 string (not guaranteed to be folded) using /id rules (w/len). */
+#define EXACTFL 33 /* 0x21 Match this string (not guaranteed to be folded) using /il rules (w/len). */
+#define EXACTFU 34 /* 0x22 Match this string (folded iff in UTF-8, length in folding doesn't change if not in UTF-8) using /iu rules (w/len). */
+#define EXACTFA 35 /* 0x23 Match this string (not guaranteed to be folded) using /iaa rules (w/len). */
+#define EXACTFU_SS 36 /* 0x24 Match this string (folded iff in UTF-8, length in folding may change even if not in UTF-8) using /iu rules (w/len). */
+#define EXACTFA_NO_TRIE 37 /* 0x25 Match this string (which is not trie-able; not guaranteed to be folded) using /iaa rules (w/len). */
+#define NOTHING 38 /* 0x26 Match empty string. */
+#define TAIL 39 /* 0x27 Match empty string. Can jump here from outside. */
+#define STAR 40 /* 0x28 Match this (simple) thing 0 or more times. */
+#define PLUS 41 /* 0x29 Match this (simple) thing 1 or more times. */
+#define CURLY 42 /* 0x2a Match this simple thing {n,m} times. */
+#define CURLYN 43 /* 0x2b Capture next-after-this simple thing */
+#define CURLYM 44 /* 0x2c Capture this medium-complex thing {n,m} times. */
+#define CURLYX 45 /* 0x2d Match this complex thing {n,m} times. */
+#define WHILEM 46 /* 0x2e Do curly processing and see if rest matches. */
+#define OPEN 47 /* 0x2f Mark this point in input as start of #n. */
+#define CLOSE 48 /* 0x30 Analogous to OPEN. */
+#define REF 49 /* 0x31 Match some already matched string */
+#define REFF 50 /* 0x32 Match already matched string, folded using native charset rules for non-utf8 */
+#define REFFL 51 /* 0x33 Match already matched string, folded in loc. */
+#define REFFU 52 /* 0x34 Match already matched string, folded using unicode rules for non-utf8 */
+#define REFFA 53 /* 0x35 Match already matched string, folded using unicode rules for non-utf8, no mixing ASCII, non-ASCII */
+#define NREF 54 /* 0x36 Match some already matched string */
+#define NREFF 55 /* 0x37 Match already matched string, folded using native charset rules for non-utf8 */
+#define NREFFL 56 /* 0x38 Match already matched string, folded in loc. */
+#define NREFFU 57 /* 0x39 Match already matched string, folded using unicode rules for non-utf8 */
+#define NREFFA 58 /* 0x3a Match already matched string, folded using unicode rules for non-utf8, no mixing ASCII, non-ASCII */
+#define LONGJMP 59 /* 0x3b Jump far away. */
+#define BRANCHJ 60 /* 0x3c BRANCH with long offset. */
#define IFMATCH 61 /* 0x3d Succeeds if the following matches. */
#define UNLESSM 62 /* 0x3e Fails if the following matches. */
#define SUSPEND 63 /* 0x3f "Independent" sub-RE. */
#define IFTHEN 64 /* 0x40 Switch, should be preceded by switcher. */
#define GROUPP 65 /* 0x41 Whether the group matched. */
-#define LONGJMP 66 /* 0x42 Jump far away. */
-#define BRANCHJ 67 /* 0x43 BRANCH with long offset. */
-#define EVAL 68 /* 0x44 Execute some Perl code. */
-#define MINMOD 69 /* 0x45 Next operator is not greedy. */
-#define LOGICAL 70 /* 0x46 Next opcode should set the flag only. */
-#define RENUM 71 /* 0x47 Group with independently numbered parens. */
-#define TRIE 72 /* 0x48 Match many EXACT(F[ALU]?)? at once. flags==type */
-#define TRIEC 73 /* 0x49 Same as TRIE, but with embedded charclass data */
-#define AHOCORASICK 74 /* 0x4a Aho Corasick stclass. flags==type */
-#define AHOCORASICKC 75 /* 0x4b Same as AHOCORASICK, but with embedded charclass data */
-#define GOSUB 76 /* 0x4c recurse to paren arg1 at (signed) ofs arg2 */
-#define GOSTART 77 /* 0x4d recurse to start of pattern */
-#define NGROUPP 78 /* 0x4e Whether the group matched. */
-#define INSUBP 79 /* 0x4f Whether we are in a specific recurse. */
-#define DEFINEP 80 /* 0x50 Never execute directly. */
-#define ENDLIKE 81 /* 0x51 Used only for the type field of verbs */
-#define OPFAIL 82 /* 0x52 Same as (?!) */
-#define ACCEPT 83 /* 0x53 Accepts the current matched string. */
-#define VERB 84 /* 0x54 Used only for the type field of verbs */
-#define PRUNE 85 /* 0x55 Pattern fails at this startpoint if no-backtracking through this */
-#define MARKPOINT 86 /* 0x56 Push the current location for rollback by cut. */
-#define SKIP 87 /* 0x57 On failure skip forward (to the mark) before retrying */
-#define COMMIT 88 /* 0x58 Pattern fails outright if backtracking through this */
-#define CUTGROUP 89 /* 0x59 On failure go to the next alternation in the group */
-#define KEEPS 90 /* 0x5a $& begins here. */
-#define LNBREAK 91 /* 0x5b generic newline pattern */
-#define OPTIMIZED 92 /* 0x5c Placeholder for dump. */
-#define PSEUDO 93 /* 0x5d Pseudo opcode for internal use. */
+#define EVAL 66 /* 0x42 Execute some Perl code. */
+#define MINMOD 67 /* 0x43 Next operator is not greedy. */
+#define LOGICAL 68 /* 0x44 Next opcode should set the flag only. */
+#define RENUM 69 /* 0x45 Group with independently numbered parens. */
+#define TRIE 70 /* 0x46 Match many EXACT(F[ALU]?)? at once. flags==type */
+#define TRIEC 71 /* 0x47 Same as TRIE, but with embedded charclass data */
+#define AHOCORASICK 72 /* 0x48 Aho Corasick stclass. flags==type */
+#define AHOCORASICKC 73 /* 0x49 Same as AHOCORASICK, but with embedded charclass data */
+#define GOSUB 74 /* 0x4a recurse to paren arg1 at (signed) ofs arg2 */
+#define GOSTART 75 /* 0x4b recurse to start of pattern */
+#define NGROUPP 76 /* 0x4c Whether the group matched. */
+#define INSUBP 77 /* 0x4d Whether we are in a specific recurse. */
+#define DEFINEP 78 /* 0x4e Never execute directly. */
+#define ENDLIKE 79 /* 0x4f Used only for the type field of verbs */
+#define OPFAIL 80 /* 0x50 Same as (?!) */
+#define ACCEPT 81 /* 0x51 Accepts the current matched string. */
+#define VERB 82 /* 0x52 Used only for the type field of verbs */
+#define PRUNE 83 /* 0x53 Pattern fails at this startpoint if no-backtracking through this */
+#define MARKPOINT 84 /* 0x54 Push the current location for rollback by cut. */
+#define SKIP 85 /* 0x55 On failure skip forward (to the mark) before retrying */
+#define COMMIT 86 /* 0x56 Pattern fails outright if backtracking through this */
+#define CUTGROUP 87 /* 0x57 On failure go to the next alternation in the group */
+#define KEEPS 88 /* 0x58 $& begins here. */
+#define LNBREAK 89 /* 0x59 generic newline pattern */
+#define OPTIMIZED 90 /* 0x5a Placeholder for dump. */
+#define PSEUDO 91 /* 0x5b Pseudo opcode for internal use. */
/* ------------ States ------------- */
#define TRIE_next (REGNODE_MAX + 1) /* state for TRIE */
#define TRIE_next_fail (REGNODE_MAX + 2) /* state for TRIE */
EXTCONST U8 PL_regkind[] = {
END, /* END */
END, /* SUCCEED */
- BOL, /* BOL */
- BOL, /* MBOL */
BOL, /* SBOL */
- EOL, /* EOS */
- EOL, /* EOL */
- EOL, /* MEOL */
+ BOL, /* MBOL */
EOL, /* SEOL */
+ EOL, /* MEOL */
+ EOL, /* EOS */
+ GPOS, /* GPOS */
BOUND, /* BOUND */
BOUND, /* BOUNDL */
BOUND, /* BOUNDU */
NBOUND, /* NBOUNDL */
NBOUND, /* NBOUNDU */
NBOUND, /* NBOUNDA */
- GPOS, /* GPOS */
REG_ANY, /* REG_ANY */
REG_ANY, /* SANY */
REG_ANY, /* CANY */
REF, /* NREFFL */
REF, /* NREFFU */
REF, /* NREFFA */
+ LONGJMP, /* LONGJMP */
+ BRANCHJ, /* BRANCHJ */
BRANCHJ, /* IFMATCH */
BRANCHJ, /* UNLESSM */
BRANCHJ, /* SUSPEND */
BRANCHJ, /* IFTHEN */
GROUPP, /* GROUPP */
- LONGJMP, /* LONGJMP */
- BRANCHJ, /* BRANCHJ */
EVAL, /* EVAL */
MINMOD, /* MINMOD */
LOGICAL, /* LOGICAL */
static const U8 regarglen[] = {
0, /* END */
0, /* SUCCEED */
- 0, /* BOL */
- 0, /* MBOL */
0, /* SBOL */
- 0, /* EOS */
- 0, /* EOL */
- 0, /* MEOL */
+ 0, /* MBOL */
0, /* SEOL */
+ 0, /* MEOL */
+ 0, /* EOS */
+ 0, /* GPOS */
0, /* BOUND */
0, /* BOUNDL */
0, /* BOUNDU */
0, /* NBOUNDL */
0, /* NBOUNDU */
0, /* NBOUNDA */
- 0, /* GPOS */
0, /* REG_ANY */
0, /* SANY */
0, /* CANY */
EXTRA_SIZE(struct regnode_1), /* NREFFL */
EXTRA_SIZE(struct regnode_1), /* NREFFU */
EXTRA_SIZE(struct regnode_1), /* NREFFA */
+ EXTRA_SIZE(struct regnode_1), /* LONGJMP */
+ EXTRA_SIZE(struct regnode_1), /* BRANCHJ */
EXTRA_SIZE(struct regnode_1), /* IFMATCH */
EXTRA_SIZE(struct regnode_1), /* UNLESSM */
EXTRA_SIZE(struct regnode_1), /* SUSPEND */
EXTRA_SIZE(struct regnode_1), /* IFTHEN */
EXTRA_SIZE(struct regnode_1), /* GROUPP */
- EXTRA_SIZE(struct regnode_1), /* LONGJMP */
- EXTRA_SIZE(struct regnode_1), /* BRANCHJ */
EXTRA_SIZE(struct regnode_1), /* EVAL */
0, /* MINMOD */
0, /* LOGICAL */
static const char reg_off_by_arg[] = {
0, /* END */
0, /* SUCCEED */
- 0, /* BOL */
- 0, /* MBOL */
0, /* SBOL */
- 0, /* EOS */
- 0, /* EOL */
- 0, /* MEOL */
+ 0, /* MBOL */
0, /* SEOL */
+ 0, /* MEOL */
+ 0, /* EOS */
+ 0, /* GPOS */
0, /* BOUND */
0, /* BOUNDL */
0, /* BOUNDU */
0, /* NBOUNDL */
0, /* NBOUNDU */
0, /* NBOUNDA */
- 0, /* GPOS */
0, /* REG_ANY */
0, /* SANY */
0, /* CANY */
0, /* NREFFL */
0, /* NREFFU */
0, /* NREFFA */
+ 1, /* LONGJMP */
+ 1, /* BRANCHJ */
2, /* IFMATCH */
2, /* UNLESSM */
1, /* SUSPEND */
1, /* IFTHEN */
0, /* GROUPP */
- 1, /* LONGJMP */
- 1, /* BRANCHJ */
0, /* EVAL */
0, /* MINMOD */
0, /* LOGICAL */
EXTCONST char * const PL_reg_name[] = {
"END", /* 0000 */
"SUCCEED", /* 0x01 */
- "BOL", /* 0x02 */
+ "SBOL", /* 0x02 */
"MBOL", /* 0x03 */
- "SBOL", /* 0x04 */
- "EOS", /* 0x05 */
- "EOL", /* 0x06 */
- "MEOL", /* 0x07 */
- "SEOL", /* 0x08 */
- "BOUND", /* 0x09 */
- "BOUNDL", /* 0x0a */
- "BOUNDU", /* 0x0b */
- "BOUNDA", /* 0x0c */
- "NBOUND", /* 0x0d */
- "NBOUNDL", /* 0x0e */
- "NBOUNDU", /* 0x0f */
- "NBOUNDA", /* 0x10 */
- "GPOS", /* 0x11 */
- "REG_ANY", /* 0x12 */
- "SANY", /* 0x13 */
- "CANY", /* 0x14 */
- "ANYOF", /* 0x15 */
- "POSIXD", /* 0x16 */
- "POSIXL", /* 0x17 */
- "POSIXU", /* 0x18 */
- "POSIXA", /* 0x19 */
- "NPOSIXD", /* 0x1a */
- "NPOSIXL", /* 0x1b */
- "NPOSIXU", /* 0x1c */
- "NPOSIXA", /* 0x1d */
- "CLUMP", /* 0x1e */
- "BRANCH", /* 0x1f */
- "BACK", /* 0x20 */
- "EXACT", /* 0x21 */
- "EXACTF", /* 0x22 */
- "EXACTFL", /* 0x23 */
- "EXACTFU", /* 0x24 */
- "EXACTFA", /* 0x25 */
- "EXACTFU_SS", /* 0x26 */
- "EXACTFA_NO_TRIE", /* 0x27 */
- "NOTHING", /* 0x28 */
- "TAIL", /* 0x29 */
- "STAR", /* 0x2a */
- "PLUS", /* 0x2b */
- "CURLY", /* 0x2c */
- "CURLYN", /* 0x2d */
- "CURLYM", /* 0x2e */
- "CURLYX", /* 0x2f */
- "WHILEM", /* 0x30 */
- "OPEN", /* 0x31 */
- "CLOSE", /* 0x32 */
- "REF", /* 0x33 */
- "REFF", /* 0x34 */
- "REFFL", /* 0x35 */
- "REFFU", /* 0x36 */
- "REFFA", /* 0x37 */
- "NREF", /* 0x38 */
- "NREFF", /* 0x39 */
- "NREFFL", /* 0x3a */
- "NREFFU", /* 0x3b */
- "NREFFA", /* 0x3c */
+ "SEOL", /* 0x04 */
+ "MEOL", /* 0x05 */
+ "EOS", /* 0x06 */
+ "GPOS", /* 0x07 */
+ "BOUND", /* 0x08 */
+ "BOUNDL", /* 0x09 */
+ "BOUNDU", /* 0x0a */
+ "BOUNDA", /* 0x0b */
+ "NBOUND", /* 0x0c */
+ "NBOUNDL", /* 0x0d */
+ "NBOUNDU", /* 0x0e */
+ "NBOUNDA", /* 0x0f */
+ "REG_ANY", /* 0x10 */
+ "SANY", /* 0x11 */
+ "CANY", /* 0x12 */
+ "ANYOF", /* 0x13 */
+ "POSIXD", /* 0x14 */
+ "POSIXL", /* 0x15 */
+ "POSIXU", /* 0x16 */
+ "POSIXA", /* 0x17 */
+ "NPOSIXD", /* 0x18 */
+ "NPOSIXL", /* 0x19 */
+ "NPOSIXU", /* 0x1a */
+ "NPOSIXA", /* 0x1b */
+ "CLUMP", /* 0x1c */
+ "BRANCH", /* 0x1d */
+ "BACK", /* 0x1e */
+ "EXACT", /* 0x1f */
+ "EXACTF", /* 0x20 */
+ "EXACTFL", /* 0x21 */
+ "EXACTFU", /* 0x22 */
+ "EXACTFA", /* 0x23 */
+ "EXACTFU_SS", /* 0x24 */
+ "EXACTFA_NO_TRIE", /* 0x25 */
+ "NOTHING", /* 0x26 */
+ "TAIL", /* 0x27 */
+ "STAR", /* 0x28 */
+ "PLUS", /* 0x29 */
+ "CURLY", /* 0x2a */
+ "CURLYN", /* 0x2b */
+ "CURLYM", /* 0x2c */
+ "CURLYX", /* 0x2d */
+ "WHILEM", /* 0x2e */
+ "OPEN", /* 0x2f */
+ "CLOSE", /* 0x30 */
+ "REF", /* 0x31 */
+ "REFF", /* 0x32 */
+ "REFFL", /* 0x33 */
+ "REFFU", /* 0x34 */
+ "REFFA", /* 0x35 */
+ "NREF", /* 0x36 */
+ "NREFF", /* 0x37 */
+ "NREFFL", /* 0x38 */
+ "NREFFU", /* 0x39 */
+ "NREFFA", /* 0x3a */
+ "LONGJMP", /* 0x3b */
+ "BRANCHJ", /* 0x3c */
"IFMATCH", /* 0x3d */
"UNLESSM", /* 0x3e */
"SUSPEND", /* 0x3f */
"IFTHEN", /* 0x40 */
"GROUPP", /* 0x41 */
- "LONGJMP", /* 0x42 */
- "BRANCHJ", /* 0x43 */
- "EVAL", /* 0x44 */
- "MINMOD", /* 0x45 */
- "LOGICAL", /* 0x46 */
- "RENUM", /* 0x47 */
- "TRIE", /* 0x48 */
- "TRIEC", /* 0x49 */
- "AHOCORASICK", /* 0x4a */
- "AHOCORASICKC", /* 0x4b */
- "GOSUB", /* 0x4c */
- "GOSTART", /* 0x4d */
- "NGROUPP", /* 0x4e */
- "INSUBP", /* 0x4f */
- "DEFINEP", /* 0x50 */
- "ENDLIKE", /* 0x51 */
- "OPFAIL", /* 0x52 */
- "ACCEPT", /* 0x53 */
- "VERB", /* 0x54 */
- "PRUNE", /* 0x55 */
- "MARKPOINT", /* 0x56 */
- "SKIP", /* 0x57 */
- "COMMIT", /* 0x58 */
- "CUTGROUP", /* 0x59 */
- "KEEPS", /* 0x5a */
- "LNBREAK", /* 0x5b */
- "OPTIMIZED", /* 0x5c */
- "PSEUDO", /* 0x5d */
+ "EVAL", /* 0x42 */
+ "MINMOD", /* 0x43 */
+ "LOGICAL", /* 0x44 */
+ "RENUM", /* 0x45 */
+ "TRIE", /* 0x46 */
+ "TRIEC", /* 0x47 */
+ "AHOCORASICK", /* 0x48 */
+ "AHOCORASICKC", /* 0x49 */
+ "GOSUB", /* 0x4a */
+ "GOSTART", /* 0x4b */
+ "NGROUPP", /* 0x4c */
+ "INSUBP", /* 0x4d */
+ "DEFINEP", /* 0x4e */
+ "ENDLIKE", /* 0x4f */
+ "OPFAIL", /* 0x50 */
+ "ACCEPT", /* 0x51 */
+ "VERB", /* 0x52 */
+ "PRUNE", /* 0x53 */
+ "MARKPOINT", /* 0x54 */
+ "SKIP", /* 0x55 */
+ "COMMIT", /* 0x56 */
+ "CUTGROUP", /* 0x57 */
+ "KEEPS", /* 0x58 */
+ "LNBREAK", /* 0x59 */
+ "OPTIMIZED", /* 0x5a */
+ "PSEUDO", /* 0x5b */
/* ------------ States ------------- */
"TRIE_next", /* REGNODE_MAX +0x01 */
"TRIE_next_fail", /* REGNODE_MAX +0x02 */
"CANY_SEEN", /* 0x00000080 - PREGf_CANY_SEEN */
"GPOS_SEEN", /* 0x00000100 - PREGf_GPOS_SEEN */
"GPOS_FLOAT", /* 0x00000200 - PREGf_GPOS_FLOAT */
- "ANCH_BOL", /* 0x00000400 - PREGf_ANCH_BOL */
- "ANCH_MBOL", /* 0x00000800 - PREGf_ANCH_MBOL */
- "ANCH_SBOL", /* 0x00001000 - PREGf_ANCH_SBOL */
- "ANCH_GPOS", /* 0x00002000 - PREGf_ANCH_GPOS */
+ "ANCH_MBOL", /* 0x00000400 - PREGf_ANCH_MBOL */
+ "ANCH_SBOL", /* 0x00000800 - PREGf_ANCH_SBOL */
+ "ANCH_GPOS", /* 0x00001000 - PREGf_ANCH_GPOS */
};
#endif /* DOINIT */
#ifdef DEBUGGING
-# define REG_INTFLAGS_NAME_SIZE 14
+# define REG_INTFLAGS_NAME_SIZE 13
#endif
/* The following have no fixed length. U8 so we can do strchr() on it. */
EXTCONST U8 PL_varies[] __attribute__deprecated__ = {
CLUMP, BRANCH, BACK, STAR, PLUS, CURLY, CURLYN, CURLYM, CURLYX, WHILEM,
REF, REFF, REFFL, REFFU, REFFA, NREF, NREFF, NREFFL, NREFFU, NREFFA,
- SUSPEND, IFTHEN, BRANCHJ,
+ BRANCHJ, SUSPEND, IFTHEN,
0
};
#endif /* DOINIT */
EXTCONST U8 PL_varies_bitmask[];
#else
EXTCONST U8 PL_varies_bitmask[] = {
- 0x00, 0x00, 0x00, 0xC0, 0x01, 0xFC, 0xF9, 0x9F, 0x09, 0x00, 0x00, 0x00
+ 0x00, 0x00, 0x00, 0x70, 0x00, 0x7F, 0xFE, 0x97, 0x01, 0x00, 0x00, 0x00
};
#endif /* DOINIT */
EXTCONST U8 PL_simple_bitmask[];
#else
EXTCONST U8 PL_simple_bitmask[] = {
- 0x00, 0x00, 0xFC, 0x3F, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00
+ 0x00, 0x00, 0xFF, 0x0F, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00
};
#endif /* DOINIT */
{
if ((char *)svp < (char *)GvGP(ARG2_GV)
|| (char *)svp > (char *)GvGP(ARG2_GV) + sizeof(struct gp)
- || GvREFCNT(ARG2_GV) > 1)
+ || GvREFCNT(ARG2_GV) > 2) /* "> 2" to ignore savestack's ref */
PL_sub_generation++;
else mro_method_changed_in(hv);
}
break;
case SVt_PVCV:
{
- HEK * const hek = CvNAME_HEK((CV *)sv);
+ HEK *hek =
+ CvNAMED(sv)
+ ? CvNAME_HEK((CV *)sv)
+ : GvNAME_HEK(CvGV(sv));
assert(hek);
- share_hek_hek(hek);
+ (void)share_hek_hek(hek);
cv_undef((CV *)sv);
CvNAME_HEK_set(sv, hek);
+ CvLEXICAL_on(sv);
break;
}
default:
case SVt_PVHV: *svp = MUTABLE_SV(newHV()); break;
case SVt_PVCV:
{
+ HEK * const hek = CvNAMED(sv)
+ ? CvNAME_HEK((CV *)sv)
+ : GvNAME_HEK(CvGV(sv));
+
/* Create a stub */
*svp = newSV_type(SVt_PVCV);
/* Share name */
- assert(CvNAMED(sv));
CvNAME_HEK_set(*svp,
- share_hek_hek(CvNAME_HEK((CV *)sv)));
+ share_hek_hek(hek));
+ CvLEXICAL_on(*svp);
break;
}
default: *svp = newSV(0); break;
case SAVEt_READONLY_OFF:
SvREADONLY_off(ARG0_SV);
break;
+ case SAVEt_GP_ALIASED_SV: {
+ /* The GP may have been abandoned, leaving the savestack with
+ the only remaining reference to it. */
+ GP * const gp = (GP *)ARG0_PTR;
+ if (gp->gp_refcnt == 1) {
+ GV * const gv = (GV *)sv_2mortal(newSV_type(SVt_PVGV));
+ GvGP_set(gv,gp);
+ gp_free(gv);
+ }
+ else {
+ gp->gp_refcnt--;
+ if (uv >> 8) gp->gp_flags |= GPf_ALIASED_SV;
+ else gp->gp_flags &= ~GPf_ALIASED_SV;
+ }
+ break;
+ }
default:
Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type);
}
#define SAVEt_CLEARPADRANGE 1
#define SAVEt_CLEARSV 2
#define SAVEt_REGCONTEXT 3
-/*** SPARE 4 ***/
-#define SAVEt_ARG0_MAX 4
+#define SAVEt_ARG0_MAX 3
/* one arg */
+#define SAVEt_GP_ALIASED_SV 4
#define SAVEt_BOOL 5
#define SAVEt_COMPILE_WARNINGS 6
#define SAVEt_COMPPAD 7
# include <rms.h>
#endif
-#ifndef HAS_C99
-# if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L && !defined(__VMS)
-# define HAS_C99 1
-# endif
-#endif
-#ifdef HAS_C99
-# include <stdint.h>
-#endif
-
#ifdef __Lynx__
/* Missing proto on LynxOS */
char *gconvert(double, int, int, char *);
#endif
+#ifdef USE_QUADMATH
+# define SNPRINTF_G(nv, buffer, size, ndig) \
+ quadmath_snprintf(buffer, size, "%.*Qg", (int)ndig, (NV)(nv))
+#else
+# define SNPRINTF_G(nv, buffer, size, ndig) \
+ PERL_UNUSED_RESULT(Gconvert((NV)(nv), (int)ndig, 0, buffer))
+#endif
+
#ifdef PERL_NEW_COPY_ON_WRITE
# ifndef SV_COW_THRESHOLD
# define SV_COW_THRESHOLD 0 /* COW iff len > K */
GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \
GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \
)
-/* void Gconvert: on Linux at least, gcvt (which Gconvert gets deffed to),
- * has a mandatory return value, even though that value is just the same
- * as the buf arg */
#ifdef PERL_UTF8_CACHE_ASSERT
/* if adding more checks watch out for the following tests:
if (! numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
- PTR2UV(sv), SvNVX(sv)));
-#else
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv)));
-#endif
#ifdef NV_PRESERVES_UV
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ if (Perl_isnan(SvNVX(sv))) {
+ SvUV_set(sv, 0);
+ SvIsUV_on(sv);
+ return FALSE;
+ }
+#endif
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
SvIV_set(sv, I_V(SvNVX(sv)));
if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
return (IV)value;
}
}
+
+ /* Quite wrong but no good choices. */
+ if ((numtype & IS_NUMBER_INFINITY)) {
+ return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
+ } else if ((numtype & IS_NUMBER_NAN)) {
+ return 0; /* So wrong. */
+ }
+
if (!numtype) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
if (!(numtype & IS_NUMBER_NEG))
return value;
}
+
+ /* Quite wrong but no good choices. */
+ if ((numtype & IS_NUMBER_INFINITY)) {
+ return UV_MAX; /* So wrong. */
+ } else if ((numtype & IS_NUMBER_NAN)) {
+ return 0; /* So wrong. */
+ }
+
if (!numtype) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
if (SvTYPE(sv) < SVt_NV) {
/* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
sv_upgrade(sv, SVt_NV);
-#ifdef USE_LONG_DOUBLE
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
- PTR2UV(sv), SvNVX(sv));
- RESTORE_NUMERIC_LOCAL();
- });
-#else
- DEBUG_c({
- STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
+ "0x%"UVxf" num(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
-#endif
}
else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
== IS_NUMBER_IN_UV) {
/* It's definitely an integer */
SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
- } else
- SvNV_set(sv, Atof(SvPVX_const(sv)));
+ } else {
+ if ((numtype & IS_NUMBER_INFINITY)) {
+ SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
+ } else if ((numtype & IS_NUMBER_NAN)) {
+ SvNV_set(sv, NV_NAN);
+ } else
+ SvNV_set(sv, Atof(SvPVX_const(sv)));
+ }
if (numtype)
SvNOK_on(sv);
else
/* Both already have p flags, so do nothing */
} else {
const NV nv = SvNVX(sv);
+ /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
if (SvIVX(sv) == I_V(nv)) {
SvNOK_on(sv);
and ideally should be fixed. */
return 0.0;
}
-#if defined(USE_LONG_DOUBLE)
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
+ PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
-#else
- DEBUG_c({
- STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
- PTR2UV(sv), SvNVX(sv));
- RESTORE_NUMERIC_LOCAL();
- });
-#endif
return SvNVX(sv);
}
return ptr;
}
+/* Helper for sv_2pv_flags and sv_vcatpvfn_flags. If the NV is an
+ * infinity or a not-a-number, writes the appropriate strings to the
+ * buffer, including a zero byte. On success returns the written length,
+ * excluding the zero byte, on failure (not an infinity, not a nan, or the
+ * maxlen too small) returns zero. */
+STATIC size_t
+S_infnan_2pv(NV nv, char* buffer, size_t maxlen) {
+ /* XXX this should be an assert */
+ if (maxlen < 4) /* "Inf\0", "NaN\0" */
+ return 0;
+ else {
+ char* s = buffer;
+ /* isnan must be first due to NAN_COMPARE_BROKEN builds, since NAN might
+ use the broken for NAN >/< ops in the inf check, and then the inf
+ check returns true for NAN on NAN_COMPARE_BROKEN compilers */
+ if (Perl_isnan(nv)) {
+ *s++ = 'N';
+ *s++ = 'a';
+ *s++ = 'N';
+ /* XXX optionally output the payload mantissa bits as
+ * "(unsigned)" (to match the nan("...") C99 function,
+ * or maybe as "(0xhhh...)" would make more sense...
+ * provide a format string so that the user can decide?
+ * NOTE: would affect the maxlen and assert() logic.*/
+ }
+ else if (Perl_isinf(nv)) {
+ if (nv < 0) {
+ if (maxlen < 5) /* "-Inf\0" */
+ return 0;
+ *s++ = '-';
+ }
+ *s++ = 'I';
+ *s++ = 'n';
+ *s++ = 'f';
+ }
+
+ else
+ return 0;
+ assert((s == buffer + 3) || (s == buffer + 4));
+ *s++ = 0;
+ return s - buffer - 1; /* -1: excluding the zero byte */
+ }
+}
+
/*
=for apidoc sv_2pv_flags
else if (SvNOK(sv)) {
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
- if (SvNVX(sv) == 0.0) {
+ if (SvNVX(sv) == 0.0
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ && !Perl_isnan(SvNVX(sv))
+#endif
+ ) {
s = SvGROW_mutable(sv, 2);
*s++ = '0';
*s = '\0';
} else {
- dSAVE_ERRNO;
/* The +20 is pure guesswork. Configure test needed. --jhi */
- s = SvGROW_mutable(sv, NV_DIG + 20);
- /* some Xenix systems wipe out errno here */
+ STRLEN size = NV_DIG + 20;
+ STRLEN len;
+ s = SvGROW_mutable(sv, size);
+
+ len = S_infnan_2pv(SvNVX(sv), s, size);
+ if (len > 0)
+ s += len;
+ else {
+ dSAVE_ERRNO;
+ /* some Xenix systems wipe out errno here */
#ifndef USE_LOCALE_NUMERIC
- PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
- SvPOK_on(sv);
+ SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
+
+ SvPOK_on(sv);
#else
- {
- DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
- PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
-
- /* If the radix character is UTF-8, and actually is in the
- * output, turn on the UTF-8 flag for the scalar */
- if (PL_numeric_local
- && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
- && instr(s, SvPVX_const(PL_numeric_radix_sv)))
{
- SvUTF8_on(sv);
+ DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
+ SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
+
+ /* If the radix character is UTF-8, and actually is in the
+ * output, turn on the UTF-8 flag for the scalar */
+ if (PL_numeric_local
+ && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
+ && instr(s, SvPVX_const(PL_numeric_radix_sv)))
+ {
+ SvUTF8_on(sv);
+ }
+ RESTORE_LC_NUMERIC();
}
- RESTORE_LC_NUMERIC();
- }
- /* We don't call SvPOK_on(), because it may come to pass that the
- * locale changes so that the stringification we just did is no
- * longer correct. We will have to re-stringify every time it is
- * needed */
+ /* We don't call SvPOK_on(), because it may come to
+ * pass that the locale changes so that the
+ * stringification we just did is no longer correct. We
+ * will have to re-stringify every time it is needed */
#endif
- RESTORE_ERRNO;
- while (*s) s++;
+ RESTORE_ERRNO;
+ }
+ while (*s) s++;
}
}
else if (isGV_with_GP(sv)) {
PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
- if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv))
- mg_get(ssv);
- s = SvPV_nomg_const(ssv,len);
+ s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
sv_setpvn(dsv,s,len);
if (SvUTF8(ssv))
SvUTF8_on(dsv);
* set so starts from there. Otherwise, can use memory copy to
* get up to where we are now, and then start from here */
- if (invariant_head <= 0) {
+ if (invariant_head == 0) {
d = dst;
} else {
Copy(s, dst, invariant_head, char);
}
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
GvASSUMECV_on(dstr);
- if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
+ if(GvSTASH(dstr)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
+ if (intro && GvREFCNT(dstr) > 1) {
+ /* temporary remove extra savestack's ref */
+ --GvREFCNT(dstr);
+ gv_method_changed(dstr);
+ ++GvREFCNT(dstr);
+ }
+ else gv_method_changed(dstr);
+ }
}
*location = SvREFCNT_inc_simple_NN(sref);
if (import_flag && !(GvFLAGS(dstr) & import_flag)
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
GvFLAGS(dstr) |= import_flag;
}
+ if (import_flag == GVf_IMPORTED_SV) {
+ if (intro) {
+ dSS_ADD;
+ SS_ADD_PTR(gp_ref(GvGP(dstr)));
+ SS_ADD_UV(SAVEt_GP_ALIASED_SV
+ | cBOOL(GvALIASED_SV(dstr)) << 8);
+ SS_ADD_END(2);
+ }
+ /* Turn off the flag if sref is not referenced elsewhere,
+ even by weak refs. (SvRMAGICAL is a pessimistic check for
+ back refs.) */
+ if (SvREFCNT(sref) <= 2 && !SvRMAGICAL(sref))
+ GvALIASED_SV_off(dstr);
+ else
+ GvALIASED_SV_on(dstr);
+ }
if (stype == SVt_PVHV) {
const char * const name = GvNAME((GV*)dstr);
const STRLEN len = GvNAMELEN(dstr);
assert(cache);
if (PL_utf8cache < 0 && SvPOKp(sv)) {
- /* SvPOKp() because it's possible that sv has string overloading, and
- therefore is a reference, hence SvPVX() is actually a pointer.
- This cures the (very real) symptoms of RT 69422, but I'm not actually
- sure whether we should even be caching the results of UTF-8
- operations on overloading, given that nothing stops overloading
- returning a different value every time it's called. */
+ /* SvPOKp() because, if sv is a reference, then SvPVX() is actually
+ a pointer. Note that we no longer cache utf8 offsets on refer-
+ ences, but this check is still a good idea, for robustness. */
const U8 *start = (const U8 *) SvPVX_const(sv);
const STRLEN realutf8 = utf8_length(start, start + byte);
}
if (flags & SVp_NOK) {
const NV was = SvNVX(sv);
- if (NV_OVERFLOWS_INTEGERS_AT &&
+ if (!Perl_isinfnan(was) &&
+ NV_OVERFLOWS_INTEGERS_AT &&
was >= NV_OVERFLOWS_INTEGERS_AT) {
/* diag_listed_as: Lost precision when %s %f by 1 */
Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
/* I don't think we can get here. Maybe I should assert this
And if we do get here I suspect that sv_setnv will croak. NWC
Fall through. */
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
- SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
-#else
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
-#endif
}
#endif /* PERL_PRESERVE_IVUV */
if (!numtype && ckWARN(WARN_NUMERIC))
* arranged in order (although not consecutively) and that only
* [A-Za-z] are accepted by isALPHA in the C locale.
*/
- if (*d != 'z' && *d != 'Z') {
+ if (isALPHA_FOLD_NE(*d, 'z')) {
do { ++*d; } while (!isALPHA(*d));
return;
}
oops_its_num:
{
const NV was = SvNVX(sv);
- if (NV_OVERFLOWS_INTEGERS_AT &&
+ if (!Perl_isinfnan(was) &&
+ NV_OVERFLOWS_INTEGERS_AT &&
was <= -NV_OVERFLOWS_INTEGERS_AT) {
/* diag_listed_as: Lost precision when %s %f by 1 */
Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
/* I don't think we can get here. Maybe I should assert this
And if we do get here I suspect that sv_setnv will croak. NWC
Fall through. */
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
- SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
-#else
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
-#endif
}
}
#endif /* PERL_PRESERVE_IVUV */
case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
/* tied lvalues should appear to be
* scalars for backwards compatibility */
- : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
+ : (isALPHA_FOLD_EQ(LvTYPE(sv), 't'))
? "SCALAR" : "LVALUE");
case SVt_PVAV: return "ARRAY";
case SVt_PVHV: return "HASH";
PERL_ARGS_ASSERT_F0CONVERT;
+ if (Perl_isinfnan(nv)) {
+ STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len);
+ *len = n;
+ return endbuf - n;
+ }
if (neg)
nv = -nv;
if (nv < UV_MAX) {
sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
}
+#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN || \
+ LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
+ LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN
+# define LONGDOUBLE_LITTLE_ENDIAN
+#endif
+
+#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN || \
+ LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN || \
+ LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
+# define LONGDOUBLE_BIG_ENDIAN
+#endif
+
+#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
+ LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
+# define LONGDOUBLE_X86_80_BIT
+#endif
+
+#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN || \
+ LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
+# define LONGDOUBLE_DOUBLEDOUBLE
+# define DOUBLEDOUBLE_MAXBITS 1028
+#endif
+
/* vhex will contain the values (0..15) of the hex digits ("nybbles"
- * of 4 bits); 1 for the implicit 1, and at most 128 bits of mantissa,
- * four bits per xdigit. */
-#define VHEX_SIZE (1+128/4)
+ * of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits
+ * per xdigit. */
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+# define VHEX_SIZE (1+DOUBLEDOUBLE_MAXBITS/4)
+#else
+# define VHEX_SIZE (1+128/4)
+#endif
/* If we do not have a known long double format, (including not using
* long doubles, or long doubles being equal to doubles) then we will
* fall back to the ldexp/frexp route, with which we can retrieve at
* most as many bits as our widest unsigned integer type is. We try
- * to get a 64-bit unsigned integer even if we are not having 64-bit
- * UV. */
+ * to get a 64-bit unsigned integer even if we are not using a 64-bit UV.
+ *
+ * (If you want to test the case of UVSIZE == 4, NVSIZE == 8,
+ * set the MANTISSATYPE to int and the MANTISSASIZE to 4.)
+ */
#if defined(HAS_QUAD) && defined(Uquad_t)
# define MANTISSATYPE Uquad_t
# define MANTISSASIZE 8
#else
-# define MANTISSATYPE UV /* May lose precision if UVSIZE is not 8. */
+# define MANTISSATYPE UV
# define MANTISSASIZE UVSIZE
#endif
+/* We make here the wild assumption that the endianness of doubles
+ * is similar to the endianness of integers, and that there is no
+ * middle-endianness. This may come back to haunt us (the rumor
+ * has it that ARM can be quite haunted). */
+#if BYTEORDER == 0x12345678 || BYTEORDER == 0x1234 || \
+ defined(DOUBLEKIND_LITTLE_ENDIAN)
+# define HEXTRACT_LITTLE_ENDIAN
+#else
+# define HEXTRACT_BIG_ENDIAN
+#endif
+
/* S_hextract() is a helper for Perl_sv_vcatpvfn_flags, for extracting
* the hexadecimal values (for %a/%A). The nv is the NV where the value
* are being extracted from (either directly from the long double in-memory
* repetitions below, but usually only one (or sometimes two)
* of them is really being used. */
/* HEXTRACT_OUTPUT() extracts the high nybble first. */
-#define HEXTRACT_OUTPUT() \
+#define HEXTRACT_OUTPUT_HI(ix) (*v++ = nvp[ix] >> 4)
+#define HEXTRACT_OUTPUT_LO(ix) (*v++ = nvp[ix] & 0xF)
+#define HEXTRACT_OUTPUT(ix) \
STMT_START { \
- *v++ = nvp[ix] >> 4; \
- *v++ = nvp[ix] & 0xF; \
- } STMT_END
-#define HEXTRACT_COUNT() \
+ HEXTRACT_OUTPUT_HI(ix); HEXTRACT_OUTPUT_LO(ix); \
+ } STMT_END
+#define HEXTRACT_COUNT(ix, c) \
STMT_START { \
- v += 2; \
- if (ix < ixmin) \
- ixmin = ix; \
- else if (ix > ixmax) \
- ixmax = ix; \
- } STMT_END
-#define HEXTRACT_IMPLICIT_BIT() \
- if (exponent) { \
- if (vend) \
- *v++ = 1; \
- else \
- v++; \
- }
+ v += c; if (ix < ixmin) ixmin = ix; else if (ix > ixmax) ixmax = ix; \
+ } STMT_END
+#define HEXTRACT_BYTE(ix) \
+ STMT_START { \
+ if (vend) HEXTRACT_OUTPUT(ix); else HEXTRACT_COUNT(ix, 2); \
+ } STMT_END
+#define HEXTRACT_LO_NYBBLE(ix) \
+ STMT_START { \
+ if (vend) HEXTRACT_OUTPUT_LO(ix); else HEXTRACT_COUNT(ix, 1); \
+ } STMT_END
+# define HEXTRACT_IMPLICIT_BIT(nv) \
+ STMT_START { \
+ if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
+ } STMT_END
- /* First see if we are using long doubles. */
-#if NVSIZE > DOUBLESIZE && LONG_DOUBLEKIND != LONG_DOUBLE_IS_DOUBLE
- const U8* nvp = (const U8*)(&nv);
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+# define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/8)
+#else
# define HEXTRACTSIZE NVSIZE
+#endif
+
+ const U8* nvp = (const U8*)(&nv);
+ const U8* vmaxend = vhex + 2 * HEXTRACTSIZE + 1;
(void)Perl_frexp(PERL_ABS(nv), exponent);
+ if (vend && (vend <= vhex || vend > vmaxend))
+ Perl_croak(aTHX_ "Hexadecimal float: internal error");
+
+ /* First check if using long doubles. */
+#if NVSIZE > DOUBLESIZE
# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
/* Used in e.g. VMS and HP-UX IA-64, e.g. -0.1L:
* 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f */
/* The bytes 13..0 are the mantissa/fraction,
* the 15,14 are the sign+exponent. */
- HEXTRACT_IMPLICIT_BIT();
+ HEXTRACT_IMPLICIT_BIT(nv);
for (ix = 13; ix >= 0; ix--) {
- if (vend)
- HEXTRACT_OUTPUT();
- else
- HEXTRACT_COUNT();
+ HEXTRACT_BYTE(ix);
}
# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN
/* Used in e.g. Solaris Sparc and HP-UX PA-RISC, e.g. -0.1L:
* bf fb 99 99 99 99 99 99 99 99 99 99 99 99 99 9a */
/* The bytes 2..15 are the mantissa/fraction,
* the 0,1 are the sign+exponent. */
- HEXTRACT_IMPLICIT_BIT();
+ HEXTRACT_IMPLICIT_BIT(nv);
for (ix = 2; ix <= 15; ix++) {
- if (vend)
- HEXTRACT_OUTPUT();
- else
- HEXTRACT_COUNT();
+ HEXTRACT_BYTE(ix);
}
# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
/* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
* be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux and OS X),
* meaning that 2 or 6 bytes are empty padding. */
/* The bytes 7..0 are the mantissa/fraction */
- /* There explicitly is *no* implicit bit in this case. */
+
+ /* Intentionally NO HEXTRACT_IMPLICIT_BIT here. */
for (ix = 7; ix >= 0; ix--) {
- if (vend)
- HEXTRACT_OUTPUT();
- else
- HEXTRACT_COUNT();
+ HEXTRACT_BYTE(ix);
}
# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
- /* The last 8 bytes are the mantissa/fraction.
- * (does this format ever happen?) */
- /* There explicitly is *no* implicit bit in this case. */
- for (ix = LONGDBLSIZE - 8; ix < LONGDBLSIZE; ix++) {
- if (vend)
- HEXTRACT_OUTPUT();
- else
- HEXTRACT_COUNT();
- }
-# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN
- /* Where is this used?
+ /* Does this format ever happen? (Wikipedia says the Motorola
+ * 6888x math coprocessors used format _like_ this but padded
+ * to 96 bits with 16 unused bits between the exponent and the
+ * mantissa.) */
+
+ /* Intentionally NO HEXTRACT_IMPLICIT_BIT here. */
+ for (ix = 0; ix < 8; ix++) {
+ HEXTRACT_BYTE(ix);
+ }
+# elif defined(LONGDOUBLE_DOUBLEDOUBLE)
+ /* Double-double format: two doubles next to each other.
+ * The first double is the high-order one, exactly like
+ * it would be for a "lone" double. The second double
+ * is shifted down using the exponent so that that there
+ * are no common bits. The tricky part is that the value
+ * of the double-double is the SUM of the two doubles and
+ * the second one can be also NEGATIVE.
*
- * Guessing that the format would be the reverse
- * of big endian, i.e. for -0.1L:
- * 9a 99 99 99 99 99 59 3c 9a 99 99 99 99 99 b9 bf */
- HEXTRACT_IMPLICIT_BIT();
- for (ix = 13; ix >= 8; ix--) {
- if (vend)
- HEXTRACT_OUTPUT();
- else
- HEXTRACT_COUNT();
- }
- for (ix = 5; ix >= 0; ix--) {
- if (vend)
- HEXTRACT_OUTPUT();
- else
- HEXTRACT_COUNT();
- }
-# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
- /* Used in e.g. PPC/Power (AIX) and MIPS.
+ * Because of this tricky construction the bytewise extraction we
+ * use for the other long double formats doesn't work, we must
+ * extract the values bit by bit.
*
- * The mantissa bits are in two separate stretches,
- * e.g. for -0.1L:
- * bf b9 99 99 99 99 99 9a 3c 59 99 99 99 99 99 9a
+ * The little-endian double-double is used .. somewhere?
*
- * Note that this blind copying might be considered not to be
- * the right thing, since the first double already does
- * rounding (0x9A as opposed to 0x99). But then again, we
- * probably should just copy the bits as they are?
+ * The big endian double-double is used in e.g. PPC/Power (AIX)
+ * and MIPS (SGI).
+ *
+ * The mantissa bits are in two separate stretches, e.g. for -0.1L:
+ * 9a 99 99 99 99 99 59 bc 9a 99 99 99 99 99 b9 3f (LE)
+ * 3f b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE)
*/
- HEXTRACT_IMPLICIT_BIT();
- for (ix = 2; ix < 8; ix++) {
+
+ if (nv == (NV)0.0) {
if (vend)
- HEXTRACT_OUTPUT();
+ *v++ = 0;
else
- HEXTRACT_COUNT();
+ v++;
+ *exponent = 0;
}
- for (ix = 10; ix < 16; ix++) {
- if (vend)
- HEXTRACT_OUTPUT();
- else
- HEXTRACT_COUNT();
+ else {
+ NV d = nv < 0 ? -nv : nv;
+ NV e = (NV)1.0;
+ U8 ha = 0x0; /* hexvalue accumulator */
+ U8 hd = 0x8; /* hexvalue digit */
+
+ /* Shift d and e (and update exponent) so that e <= d < 2*e,
+ * this is essentially manual frexp(). Multiplying by 0.5 and
+ * doubling should be lossless in binary floating point. */
+
+ *exponent = 1;
+
+ while (e > d) {
+ e *= (NV)0.5;
+ (*exponent)--;
+ }
+ /* Now d >= e */
+
+ while (d >= e + e) {
+ e += e;
+ (*exponent)++;
+ }
+ /* Now e <= d < 2*e */
+
+ /* First extract the leading hexdigit (the implicit bit). */
+ if (d >= e) {
+ d -= e;
+ if (vend)
+ *v++ = 1;
+ else
+ v++;
+ }
+ else {
+ if (vend)
+ *v++ = 0;
+ else
+ v++;
+ }
+ e *= (NV)0.5;
+
+ /* Then extract the remaining hexdigits. */
+ while (d > (NV)0.0) {
+ if (d >= e) {
+ ha |= hd;
+ d -= e;
+ }
+ if (hd == 1) {
+ /* Output or count in groups of four bits,
+ * that is, when the hexdigit is down to one. */
+ if (vend)
+ *v++ = ha;
+ else
+ v++;
+ /* Reset the hexvalue. */
+ ha = 0x0;
+ hd = 0x8;
+ }
+ else
+ hd >>= 1;
+ e *= (NV)0.5;
+ }
+
+ /* Flush possible pending hexvalue. */
+ if (ha) {
+ if (vend)
+ *v++ = ha;
+ else
+ v++;
+ }
}
# else
Perl_croak(aTHX_
"Hexadecimal float: unsupported long double format");
# endif
#else
- /* If not using long doubles (or if the long double format is
- * known but not yet supported), try to retrieve the mantissa bits
- * via frexp+ldexp. */
-
- NV norm = Perl_frexp(PERL_ABS(nv), exponent);
- /* Theoretically we have all the bytes [0, MANTISSASIZE-1] to
- * inspect; but in practice we don't want the leading nybbles that
- * are zero. With the common IEEE 754 value for NV_MANT_DIG being
- * 53, we want the limit byte to be (int)((53-1)/8) == 6.
- *
- * Note that this is _not_ inspecting the in-memory format of the
- * nv (as opposed to the long double method), but instead the UV
- * retrieved with the frexp+ldexp invocation. */
-# if MANTISSASIZE * 8 > NV_MANT_DIG
- MANTISSATYPE mantissa = Perl_ldexp(norm, NV_MANT_DIG);
- int limit_byte = (NV_MANT_DIG - 1) / 8;
-# else
- /* There will be low-order precision loss. Try to salvage as many
- * bits as possible. Will truncate, not round. */
- MANTISSATYPE mantissa =
- Perl_ldexp(norm,
- /* The highest possible shift by two that fits in the
- * mantissa and is aligned (by four) the same was as
- * NV_MANT_DIG. */
- MANTISSASIZE * 8 - (4 - NV_MANT_DIG % 4));
- int limit_byte = MANTISSASIZE - 1;
-# endif
- const U8* nvp = (const U8*)(&mantissa);
-# define HEXTRACTSIZE MANTISSASIZE
- /* We make here the wild assumption that the endianness of doubles
- * is similar to the endianness of integers, and that there is no
- * middle-endianness. This may come back to haunt us (the rumor
- * has it that ARM can be quite haunted).
+ /* Using normal doubles, not long doubles.
*
* We generate 4-bit xdigits (nybble/nibble) instead of 8-bit
- * bytes, since we might need to handle printf precision, and also
- * insert the radix.
- */
-# if BYTEORDER == 0x12345678 || BYTEORDER == 0x1234 || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN
- /* Little endian. */
- for (ix = limit_byte; ix >= 0; ix--) {
- if (vend)
- HEXTRACT_OUTPUT();
- else
- HEXTRACT_COUNT();
+ * bytes, since we might need to handle printf precision, and
+ * also need to insert the radix. */
+ HEXTRACT_IMPLICIT_BIT(nv);
+# ifdef HEXTRACT_LITTLE_ENDIAN
+ HEXTRACT_LO_NYBBLE(6);
+ for (ix = 5; ix >= 0; ix--) {
+ HEXTRACT_BYTE(ix);
}
# else
- /* Big endian. */
- for (ix = MANTISSASIZE - 1 - limit_byte; ix < MANTISSASIZE; ix++) {
- if (vend)
- HEXTRACT_OUTPUT();
- else
- HEXTRACT_COUNT();
+ HEXTRACT_LO_NYBBLE(1);
+ for (ix = 2; ix < HEXTRACTSIZE; ix++) {
+ HEXTRACT_BYTE(ix);
}
# endif
- /* If there are not enough bits in MANTISSATYPE, we couldn't get
- * all of them, issue a warning.
- *
- * Note that NV_PRESERVES_UV_BITS would not help here, it is the
- * wrong way around. */
-# if NV_MANT_DIG > MANTISSASIZE * 8
- Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "Hexadecimal float: precision loss");
-# endif
#endif
/* Croak for various reasons: if the output pointer escaped the
* output buffer, if the extraction index escaped the extraction
* buffer, or if the ending output pointer didn't match the
* previously computed value. */
if (v <= vhex || v - vhex >= VHEX_SIZE ||
+ /* For double-double the ixmin and ixmax stay at zero,
+ * which is convenient since the HEXTRACTSIZE is tricky
+ * for double-double. */
ixmin < 0 || ixmax >= HEXTRACTSIZE ||
(vend && v != vend))
Perl_croak(aTHX_ "Hexadecimal float: internal error");
* NV_DIG: mantissa takes than many decimal digits.
* Plus 32: Playing safe. */
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? */
- bool hexfp = FALSE;
+ bool hexfp = FALSE; /* hexadecimal floating point? */
DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED;
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') {
- /* Add check for digits != 0 because it seems that some
- gconverts are buggy in this case, and we don't yet have
- a Configure test for this. */
- if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
- /* 0, point, slack */
- STORE_LC_NUMERIC_SET_TO_NEEDED();
- PERL_UNUSED_RESULT(Gconvert(nv, (int)digits, 0, ebuf));
- sv_catpv_nomg(sv, ebuf);
- if (*ebuf) /* May return an empty string for digits==0 */
- return;
- }
- } else if (!digits) {
- STRLEN l;
+ if (LIKELY(!Perl_isinfnan(nv))) {
+ if (*pp == 'g') {
+ /* Add check for digits != 0 because it seems that some
+ gconverts are buggy in this case, and we don't yet have
+ a Configure test for this. */
+ if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
+ /* 0, point, slack */
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
+ SNPRINTF_G(nv, ebuf, size, digits);
+ sv_catpv_nomg(sv, ebuf);
+ if (*ebuf) /* May return an empty string for digits==0 */
+ return;
+ }
+ } else if (!digits) {
+ STRLEN l;
- if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
- sv_catpvn_nomg(sv, p, l);
- return;
- }
- }
+ if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
+ sv_catpvn_nomg(sv, p, l);
+ return;
+ }
+ }
+ }
}
}
#endif /* !USE_LONG_DOUBLE */
unsigned base = 0;
IV iv = 0;
UV uv = 0;
- /* we need a long double target in case HAS_LONG_DOUBLE but
- not USE_LONG_DOUBLE
+ /* We need a long double target in case HAS_LONG_DOUBLE,
+ * even without USE_LONG_DOUBLE, so that we can printf with
+ * long double formats, even without NV being long double.
+ * But we call the target 'fv' instead of 'nv', since most of
+ * the time it is not (most compilers these days recognize
+ * "long double", even if only as a synonym for "double").
*/
-#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
- long double nv;
+#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && \
+ defined(PERL_PRIgldbl) && !defined(USE_QUADMATH)
+ long double fv;
+# define FV_ISFINITE(x) Perl_isfinitel(x)
+# define FV_GF PERL_PRIgldbl
#else
- NV nv;
+ NV fv;
+# define FV_ISFINITE(x) Perl_isfinite((NV)(x))
+# define FV_GF NVgf
#endif
STRLEN have;
STRLEN need;
I32 epix = 0; /* explicit precision index */
I32 evix = 0; /* explicit vector index */
bool asterisk = FALSE;
+ bool infnan = FALSE;
/* echo everything up to the next format specification */
for (q = p; q < patend && *q != '%'; ++q) ;
#if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
case 'L': /* Ld */
/* FALLTHROUGH */
+#ifdef USE_QUADMATH
+ case 'Q':
+ /* FALLTHROUGH */
+#endif
#if IVSIZE >= 8
case 'q': /* qd */
#endif
case 'V':
case 'z':
case 't':
-#ifdef HAS_C99
+#ifdef I_STDINT
case 'j':
#endif
intsize = *q++;
}
}
+ if (argsv && SvNOK(argsv)) {
+ /* XXX va_arg(*args) case? */
+ infnan = Perl_isinfnan(SvNV(argsv));
+ }
+
switch (c = *q++) {
/* STRINGS */
case 'c':
if (vectorize)
goto unknown;
- uv = (args) ? va_arg(*args, int) : SvIV(argsv);
+ uv = (args) ? va_arg(*args, int) :
+ infnan ? UNICODE_REPLACEMENT : SvIV(argsv);
if ((uv > 255 ||
(!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv)))
&& !IN_BYTES) {
/* INTEGERS */
case 'p':
+ if (infnan) {
+ c = 'g';
+ goto floating_point;
+ }
if (alt || vectorize)
goto unknown;
uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
/* FALLTHROUGH */
case 'd':
case 'i':
+ if (infnan) {
+ c = 'g';
+ goto floating_point;
+ }
if (vectorize) {
STRLEN ulen;
if (!veclen)
case 't': iv = va_arg(*args, ptrdiff_t); break;
#endif
default: iv = va_arg(*args, int); break;
-#ifdef HAS_C99
+#ifdef I_STDINT
case 'j': iv = va_arg(*args, intmax_t); break;
#endif
case 'q':
base = 16;
uns_integer:
+ if (infnan) {
+ c = 'g';
+ goto floating_point;
+ }
if (vectorize) {
STRLEN ulen;
vector:
#ifdef HAS_PTRDIFF_T
case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
#endif
-#ifdef HAS_C99
+#ifdef I_STDINT
case 'j': uv = va_arg(*args, uintmax_t); break;
#endif
default: uv = va_arg(*args, unsigned); break;
/* FLOATING POINT */
+ floating_point:
+
case 'F':
c = 'f'; /* maybe %F isn't supported here */
/* FALLTHROUGH */
goto unknown;
}
- /* now we need (long double) if intsize == 'q', else (double) */
- nv = (args) ?
-#if LONG_DOUBLESIZE > DOUBLESIZE
- intsize == 'q' ?
- va_arg(*args, long double) :
- va_arg(*args, double)
+ /* Now we need (long double) if intsize == 'q', else (double). */
+ if (args) {
+ /* Note: do not pull NVs off the va_list with va_arg()
+ * (pull doubles instead) because if you have a build
+ * with long doubles, you would always be pulling long
+ * doubles, which would badly break anyone using only
+ * doubles (i.e. the majority of builds). In other
+ * words, you cannot mix doubles and long doubles.
+ * The only case where you can pull off long doubles
+ * is when the format specifier explicitly asks so with
+ * e.g. "%Lg". */
+#ifdef USE_QUADMATH
+ fv = intsize == 'q' ?
+ va_arg(*args, NV) : va_arg(*args, double);
+#elif LONG_DOUBLESIZE > DOUBLESIZE
+ fv = intsize == 'q' ?
+ va_arg(*args, long double) : va_arg(*args, double);
#else
- va_arg(*args, double)
+ fv = va_arg(*args, double);
#endif
- : SvNV(argsv);
+ }
+ else
+ fv = SvNV(argsv);
need = 0;
- /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
- else. frexp() has some unspecified behaviour for those three */
- if (c != 'e' && c != 'E' && (nv * 0) == 0) {
+ /* frexp() (or frexpl) has some unspecified behaviour for
+ * nan/inf/-inf, so let's avoid calling that on non-finites. */
+ if (isALPHA_FOLD_NE(c, 'e') && FV_ISFINITE(fv)) {
i = PERL_INT_MIN;
- /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
- will cast our (long double) to (double) */
- (void)Perl_frexp(nv, &i);
+ (void)Perl_frexp((NV)fv, &i);
if (i == PERL_INT_MIN)
- Perl_die(aTHX_ "panic: frexp");
- hexfp = (c == 'a' || c == 'A');
+ Perl_die(aTHX_ "panic: frexp: %"FV_GF, fv);
+ /* Do not set hexfp earlier since we want to printf
+ * Inf/NaN for Inf/NaN, not their hexfp. */
+ hexfp = isALPHA_FOLD_EQ(c, 'a');
if (UNLIKELY(hexfp)) {
- /* Hexadecimal floating point: this size
- * computation probably overshoots, but that is
- * better than undershooting. */
+ /* This seriously overshoots in most cases, but
+ * better the undershooting. Firstly, all bytes
+ * of the NV are not mantissa, some of them are
+ * exponent. Secondly, for the reasonably common
+ * long doubles case, the "80-bit extended", two
+ * or six bytes of the NV are unused. */
need +=
- (nv < 0) + /* possible unary minus */
+ (fv < 0) ? 1 : 0 + /* possible unary minus */
2 + /* "0x" */
1 + /* the very unlikely carry */
1 + /* "1" */
1 + /* "." */
- /* We want one byte per each 4 bits in the
- * mantissa. This works out to about 0.83
- * bytes per NV decimal digit (of 4 bits):
- * (NV_DIG * log(10)/log(2)) / 4,
- * we overestimate by using 5/6 (0.8333...) */
- ((NV_DIG * 5) / 6 + 1) +
+ 2 * NVSIZE + /* 2 hexdigits for each byte */
2 + /* "p+" */
- (i >= 0 ? BIT_DIGITS(i) : 1 + BIT_DIGITS(-i)) +
+ 6 + /* exponent: sign, plus up to 16383 (quad fp) */
1; /* \0 */
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+ /* However, for the "double double", we need more.
+ * Since each double has their own exponent, the
+ * doubles may float (haha) rather far from each
+ * other, and the number of required bits is much
+ * larger, up to total of 1028 bits. (NOTE: this
+ * is not actually implemented properly yet,
+ * we are using just the first double, see
+ * S_hextract() for details. But let's prepare
+ * for the future.) */
+
+ /* 2 hexdigits for each byte. */
+ need += (DOUBLEDOUBLE_MAXBITS/8 + 1) * 2;
+ /* the size for the exponent already added */
+#endif
#ifdef USE_LOCALE_NUMERIC
STORE_LC_NUMERIC_SET_TO_NEEDED();
if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC))
# endif
if ((intsize == 'q') && (c == 'f') &&
- ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
+ ((fv < MY_DBL_MAX_BUG) && (fv > -MY_DBL_MAX_BUG)) &&
(need < DBL_DIG)) {
/* it's going to be short enough that
* long double precision is not needed */
- if ((nv <= 0L) && (nv >= -0L))
+ if ((fv <= 0L) && (fv >= -0L))
fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
else {
/* would use Perl_fp_class as a double-check but not
* functional on IRIX - see perl.h comments */
- if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
+ if ((fv >= MY_DBL_MIN) || (fv <= -MY_DBL_MIN)) {
/* It's within the range that a double can represent */
#if defined(DBL_MAX) && !defined(DBL_MIN)
- if ((nv >= ((long double)1/DBL_MAX)) ||
- (nv <= (-(long double)1/DBL_MAX)))
+ if ((fv >= ((long double)1/DBL_MAX)) ||
+ (fv <= (-(long double)1/DBL_MAX)))
#endif
fix_ldbl_sprintf_bug = TRUE;
}
double temp;
intsize = 0;
- temp = (double)nv;
- nv = (NV)temp;
+ temp = (double)fv;
+ fv = (NV)temp;
}
}
}
if ( !(width || left || plus || alt) && fill != '0'
- && has_precis && intsize != 'q' ) { /* Shortcuts */
+ && has_precis && intsize != 'q' /* Shortcuts */
+ && LIKELY(!Perl_isinfnan((NV)fv)) ) {
/* See earlier comment about buggy Gconvert when digits,
aka precis is 0 */
- if ( c == 'g' && precis) {
+ if ( c == 'g' && precis ) {
STORE_LC_NUMERIC_SET_TO_NEEDED();
- PERL_UNUSED_RESULT(Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf));
+ SNPRINTF_G(fv, PL_efloatbuf, PL_efloatsize, precis);
/* May return an empty string for digits==0 */
if (*PL_efloatbuf) {
elen = strlen(PL_efloatbuf);
goto float_converted;
}
- } else if ( c == 'f' && !precis) {
- if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
+ } else if ( c == 'f' && !precis ) {
+ if ((eptr = F0convert(fv, ebuf + sizeof ebuf, &elen)))
break;
}
}
* human-readable xdigits. */
const char* xdig = PL_hexdigit;
int zerotail = 0; /* how many extra zeros to append */
- int exponent; /* exponent of the floating point input */
-
- vend = S_hextract(aTHX_ nv, &exponent, vhex, NULL);
- S_hextract(aTHX_ nv, &exponent, vhex, vend);
+ int exponent = 0; /* exponent of the floating point input */
+
+ /* XXX: denormals, NaN, Inf.
+ *
+ * For example with denormals, (assuming the vanilla
+ * 64-bit double): the exponent is zero. 1xp-1074 is
+ * the smallest denormal and the smallest double, it
+ * should be output as 0x0.0000000000001p-1022 to
+ * match its internal structure. */
+
+ /* Note: fv can be (and often is) long double.
+ * Here it is explicitly cast to NV. */
+ vend = S_hextract(aTHX_ (NV)fv, &exponent, vhex, NULL);
+ S_hextract(aTHX_ (NV)fv, &exponent, vhex, vend);
+
+#if NVSIZE > DOUBLESIZE
+# ifdef LONGDOUBLE_X86_80_BIT
+ exponent -= 4;
+# else
+ exponent--;
+# endif
+#endif
- if (nv < 0)
+ if (fv < 0)
*p++ = '-';
else if (plus)
*p++ = plus;
}
}
- /* Adjust the exponent so that the first output
- * xdigit aligns with the 4-bit nybbles. */
- exponent -= NV_MANT_DIG % 4 ? NV_MANT_DIG % 4 : 4;
+#if NVSIZE == DOUBLESIZE
+ if (fv != 0.0)
+ exponent--;
+#endif
if (precis > 0) {
v = vhex + precis + 1;
elen = width;
}
}
- else {
- char *ptr = ebuf + sizeof ebuf;
- *--ptr = '\0';
- *--ptr = c;
- /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
+ else
+ elen = S_infnan_2pv(fv, PL_efloatbuf, PL_efloatsize);
+
+ if (elen == 0) {
+ char *ptr = ebuf + sizeof ebuf;
+ *--ptr = '\0';
+ *--ptr = c;
+ /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
#if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
+ /* Note that this is HAS_LONG_DOUBLE and PERL_PRIfldbl,
+ * not USE_LONG_DOUBLE and NVff. In other words,
+ * this needs to work without USE_LONG_DOUBLE. */
if (intsize == 'q') {
/* Copy the one or more characters in a long double
* format before the 'base' ([efgEFG]) character to
* the format string. */
- static char const prifldbl[] = PERL_PRIfldbl;
- char const *p = prifldbl + sizeof(prifldbl) - 3;
- while (p >= prifldbl) { *--ptr = *p--; }
+#ifdef USE_QUADMATH
+ *--ptr = 'Q';
+#else
+ static char const ldblf[] = PERL_PRIfldbl;
+ char const *p = ldblf + sizeof(ldblf) - 3;
+ while (p >= ldblf) { *--ptr = *p--; }
+#endif
}
#endif
if (has_precis) {
/* hopefully the above makes ptr a very constrained format
* that is safe to use, even though it's not literal */
GCC_DIAG_IGNORE(-Wformat-nonliteral);
-#if defined(HAS_LONG_DOUBLE)
+#ifdef USE_QUADMATH
+ {
+ const char* qfmt = quadmath_format_single(ptr);
+ if (!qfmt)
+ Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr);
+ elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
+ qfmt, fv);
+ if ((IV)elen == -1)
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s|'", qfmt);
+ if (qfmt != ptr)
+ Safefree(qfmt);
+ }
+#elif defined(HAS_LONG_DOUBLE)
elen = ((intsize == 'q')
- ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
- : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
+ ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv)
+ : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)fv));
#else
- elen = my_sprintf(PL_efloatbuf, ptr, nv);
+ elen = my_sprintf(PL_efloatbuf, ptr, fv);
#endif
GCC_DIAG_RESTORE;
}
float_converted:
eptr = PL_efloatbuf;
+ assert((IV)elen > 0); /* here zero elen is bad */
#ifdef USE_LOCALE_NUMERIC
/* If the decimal point character in the string is UTF-8, make the
#ifdef HAS_PTRDIFF_T
case 't': *(va_arg(*args, ptrdiff_t*)) = i; break;
#endif
-#ifdef HAS_C99
+#ifdef I_STDINT
case 'j': *(va_arg(*args, intmax_t*)) = i; break;
#endif
case 'q':
}
}
+ assert((IV)elen >= 0); /* here zero elen is fine */
have = esignlen + zeros + elen;
if (have < zeros)
croak_memory_wrap();
(proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
parser->lex_defer = proto->lex_defer;
parser->lex_dojoin = proto->lex_dojoin;
- parser->lex_expect = proto->lex_expect;
parser->lex_formbrack = proto->lex_formbrack;
parser->lex_inpat = proto->lex_inpat;
parser->lex_inwhat = proto->lex_inwhat;
if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
if (CvNAMED(dstr))
SvANY((CV *)dstr)->xcv_gv_u.xcv_hek =
- share_hek_hek(CvNAME_HEK((CV *)sstr));
+ hek_dup(CvNAME_HEK((CV *)sstr), param);
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
else
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
break;
+ case SAVEt_GP_ALIASED_SV:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = gp_dup((GP *)ptr, param);
+ ((GP *)ptr)->gp_refcnt++;
+ break;
default:
Perl_croak(aTHX_
"panic: ss_dup inconsistency (%"IVdf")", (IV) type);
PL_minus_F = proto_perl->Iminus_F;
PL_doswitches = proto_perl->Idoswitches;
PL_dowarn = proto_perl->Idowarn;
+ PL_sawalias = proto_perl->Isawalias;
#ifdef PERL_SAWAMPERSAND
PL_sawampersand = proto_perl->Isawampersand;
#endif
PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param);
PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
+ PL_InBitmap = sv_dup_inc(proto_perl->IInBitmap, param);
PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
PL_HasMultiCharFold = sv_dup_inc(proto_perl->IHasMultiCharFold, param);
nsv = sv_newmortal();
SvSetSV_nosteal(nsv, sv);
}
- save_re_context();
PUSHMARK(sp);
EXTEND(SP, 3);
PUSHs(encoding);
dSP;
ENTER;
SAVETMPS;
- save_re_context();
PUSHMARK(sp);
EXTEND(SP, 6);
PUSHs(encoding);
/* note that SVf_AMAGIC is now only set on stashes, so this bit is free
* for non-HV SVs */
-/* Ensure this value does not clash with the GV_ADD* flags in gv.h: */
+/* Ensure this value does not clash with the GV_ADD* flags in gv.h, or the
+ CV_CKPROTO_* flags in op.c, or the padadd_* flags in pad.h: */
#define SVf_UTF8 0x20000000 /* SvPV is UTF-8 encoded
This is also set on RVs whose overloaded
stringification is UTF-8. This might
#define SvPV_flags_const(sv, lp, flags) \
(SvPOK_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \
- (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN))
+ (const char*) sv_2pv_flags(sv, &lp, (flags|SV_CONST_RETURN)))
#define SvPV_flags_const_nolen(sv, flags) \
(SvPOK_nog(sv) \
? SvPVX_const(sv) : \
- (const char*) sv_2pv_flags(sv, 0, flags|SV_CONST_RETURN))
+ (const char*) sv_2pv_flags(sv, 0, (flags|SV_CONST_RETURN)))
#define SvPV_flags_mutable(sv, lp, flags) \
(SvPOK_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \
- sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
+ sv_2pv_flags(sv, &lp, (flags|SV_MUTABLE_RETURN)))
#define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC)
#define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC)
(littlelen), SV_GMAGIC)
#define sv_mortalcopy(sv) \
Perl_sv_mortalcopy_flags(aTHX_ sv, SV_GMAGIC|SV_DO_COW_SVSETSV)
+#define sv_cathek(sv,hek) \
+ STMT_START { \
+ HEK * const bmxk = hek; \
+ sv_catpvn_flags(sv, HEK_KEY(bmxk), HEK_LEN(bmxk), \
+ HEK_UTF8(bmxk) ? SV_CATUTF8 : SV_CATBYTES); \
+ } STMT_END
/* Should be named SvCatPVN_utf8_upgrade? */
#define sv_catpvn_nomg_utf8_upgrade(dsv, sstr, slen, nsv) \
d__fwalk='undef'
d_access='undef'
d_accessx='undef'
+d_acosh='undef'
d_aintl='undef'
d_alarm='undef'
d_archlib='define'
d_fd_macros='undef'
d_fd_set='undef'
d_fds_bits='undef'
+d_fegetround='undef'
d_fgetpos='undef'
d_finite='undef'
d_finitel='undef'
d_flockproto='undef'
d_fork='undef'
d_fp_class='undef'
+d_fp_classify='undef'
+d_fp_classl='undef'
d_fpathconf='undef'
d_fpclass='undef'
d_fpclassify='undef'
d_fpclassl='undef'
+d_fpgetround='undef'
d_fpos64_t='undef'
d_frexpl='undef'
d_fs_data_s='undef'
d_isascii='undef'
d_isblank='undef'
d_isfinite='undef'
+d_isfinitel='undef'
d_isinf='undef'
+d_isinfl='undef'
d_isnan='undef'
d_isnanl='undef'
+d_j0='undef'
+d_j0l='undef'
d_killpg='undef'
d_lchown='undef'
d_ldbl_dig='undef'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
d_truncate='undef'
+d_truncl='undef'
d_ttyname_r='undef'
d_tzname='undef'
d_u32align='define'
i_dlfcn='undef'
i_execinfo='undef'
i_fcntl='define'
+i_fenv='undef'
i_float='undef'
i_fp='undef'
i_fp_class='undef'
i_prot='undef'
i_pthread='undef'
i_pwd='define'
+i_quadmath='undef'
i_rpcsvcdbm='undef'
i_sgtty='undef'
i_shadow='undef'
i_stdarg='define'
i_stdbool='undef'
i_stddef='undef'
+i_stdint='undef'
i_stdlib='define'
i_string='define'
i_sunmath='undef'
useopcode='true'
useperlio='define'
useposix='true'
+usequadmath='undef'
usereentrant='undef'
userelocatableinc='undef'
useshrplib='false'
#!./perl
-print "1..91\n";
+print "1..93\n";
$x = 'x';
print "not " unless (time
=>) eq time=>;
print "ok $test - => quotes keywords across lines\n"; $test++;
+
+# [perl #80368]
+print "not " unless eval '"a\U="' eq "a=";
+print "ok $test - [perl #80368] qq <a\\U=>\n"; $test++;
+
+sub Function_with_side_effects { $_ = "sidekick function called" }
+print "not " unless
+ (eval '${Function_with_side_effects,\$_}' || $@)
+ eq "sidekick function called";
+print "ok $test - \${...} where {...} looks like hash\n"; $test++;
# we've not yet verified that use works.
# use strict;
-print "1..29\n";
+print "1..30\n";
my $test = 0;
# Historically constant folding was performed by evaluating the ops, and if
for (1,2) { for (\(1+3)) { push @values, $$_; $$_++ } }
is "@values", "4 4",
'\1+3 folding making modification affect future retvals';
+
+{
+ BEGIN { $^W = 0; $::{u} = \undef }
+ my $w;
+ local $SIG{__WARN__} = sub { ++$w };
+ () = 1 + u;
+ is $w, 1, '1+undef_constant is not folded outside warninsg scope';
+ BEGIN { $^W = 1 }
+}
# Tests the scoping of $^H and %^H
BEGIN {
- @INC = qw(. ../lib);
+ @INC = qw(. ../lib ../ext/re);
chdir 't';
}
my $res;
BEGIN { $^H{73174} = "foo" }
BEGIN { $res = ($^H{73174} // "") }
- "" =~ /\x{100}/i; # forces loading of utf8.pm, which used to reset %^H
+ # /x{100}/i forces loading of utf8.pm, which used to reset %^H
+ eval '"" =~ /\x{100}/i; 1'
+ # Allow miniperl to fail this regexp compilation (effectively skip
+ # the test) in case tables have not been build, but require real
+ # perl to succeed.
+ or defined &DynaLoader::boot_DynaLoader and die;
BEGIN { $res .= '-' . ($^H{73174} // "")}
$res .= '-' . ($^H{73174} // "");
print $res eq "foo-foo-" ? "" : "not ",
print "ok $i - star(\\*FOO)\n";
}); $i++;
star2 FOO, BAR, sub {
- print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR';
+ print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux';
print "ok $i - star2 FOO, BAR\n";
}; $i++;
star2(Bar::BAZ, FOO, sub {
- print "not " unless $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO';
+ print "not " unless $_[0] eq 'quuz' and $_[1] eq 'FOO';
print "ok $i - star2(Bar::BAZ, FOO)\n"
}); $i++;
star2 BAR(), FOO, sub {
BEGIN {
chdir 't' if -d 't';
@INC = '.';
- push @INC, '../lib';
+ push @INC, '../lib', '../ext/re';
}
sub do_require {
@tests=grep /$re/, @tests
if $re;
+# Allow eg ./perl t/harness t/op/lc.t
+for (@tests) {
+ if (-f "../$_") {
+ $_ = "../$_";
+ s{^\.\./t/}{};
+ }
+}
+
my %options;
my $type = 'perl';
color => $color,
jobs => $jobs,
verbosity => $Verbose,
+ timer => $ENV{HARNESS_TIMER},
exec => sub {
my ($harness, $test) = @_;
# Calling unlink on a directory without -U and privileges will always fail, but
# it should set errno to EISDIR even though unlink(2) is never called.
-{
+SKIP: {
+ if (is_miniperl && !eval 'require Errno') {
+ skip "Errno not built yet", 3;
+ }
require Errno;
my $tmpdir = tempfile();
is($WARN, '', "ignore warning on embedded nul with no warnings syscalls");
}
- use Errno 'ENOENT';
- # check handling of multiple arguments, which the original patch
- # mis-handled
- $! = 0;
- is (unlink($fn, $fn), 0, "check multiple arguments to unlink");
- is($!+0, ENOENT, "check errno");
- $! = 0;
- is (chmod(0644, $fn, $fn), 0, "check multiple arguments to chmod");
- is($!+0, ENOENT, "check errno");
- $! = 0;
- is (utime(time, time, $fn, $fn), 0, "check multiple arguments to utime");
- is($!+0, ENOENT, "check errno");
SKIP: {
- skip "no chown", 2 unless $Config{d_chown};
+ if (is_miniperl && !eval 'require Errno') {
+ skip "Errno not built yet", 8;
+ }
+ require Errno;
+ import Errno 'ENOENT';
+ # check handling of multiple arguments, which the original patch
+ # mis-handled
$! = 0;
- is(chown(-1, -1, $fn, $fn), 0, "check multiple arguments to chown");
- is($!+0, ENOENT, "check errno");
+ is (unlink($fn, $fn), 0, "check multiple arguments to unlink");
+ is($!+0, &ENOENT, "check errno");
+ $! = 0;
+ is (chmod(0644, $fn, $fn), 0, "check multiple arguments to chmod");
+ is($!+0, &ENOENT, "check errno");
+ $! = 0;
+ is (utime(time, time, $fn, $fn), 0, "check multiple arguments to utime");
+ is($!+0, &ENOENT, "check errno");
+ SKIP: {
+ skip "no chown", 2 unless $Config{d_chown};
+ $! = 0;
+ is(chown(-1, -1, $fn, $fn), 0, "check multiple arguments to chown");
+ is($!+0, &ENOENT, "check errno");
+ }
}
is (unlink($fn), 0, "unlink fails with \\0 in name");
$joe = 1 ;
EXPECT
Variable "$joe" is not imported at - line 8.
-Global symbol "$joe" requires explicit package name at - line 8.
+Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 8.
Execution of - aborted due to compilation errors.
########
}
$joe = 1 ;
EXPECT
-Global symbol "$joe" requires explicit package name at - line 6.
+Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 6.
Execution of - aborted due to compilation errors.
########
use strict ;
$fred ;
EXPECT
-Global symbol "$fred" requires explicit package name at - line 4.
+Global symbol "$fred" requires explicit package name (did you forget to declare "my $fred"?) at - line 4.
Execution of - aborted due to compilation errors.
########
use strict 'vars' ;
<$fred> ;
EXPECT
-Global symbol "$fred" requires explicit package name at - line 4.
+Global symbol "$fred" requires explicit package name (did you forget to declare "my $fred"?) at - line 4.
Execution of - aborted due to compilation errors.
########
use strict 'vars' ;
local $fred ;
EXPECT
-Global symbol "$fred" requires explicit package name at - line 4.
+Global symbol "$fred" requires explicit package name (did you forget to declare "my $fred"?) at - line 4.
Execution of - aborted due to compilation errors.
########
$joe = 1 ;
EXPECT
Variable "$joe" is not imported at - line 8.
-Global symbol "$joe" requires explicit package name at - line 8.
+Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 8.
Execution of - aborted due to compilation errors.
########
$jòè = 1 ;
EXPECT
Variable "$jòè" is not imported at - line 10.
-Global symbol "$jòè" requires explicit package name at - line 10.
+Global symbol "$jòè" requires explicit package name (did you forget to declare "my $jòè"?) at - line 10.
Execution of - aborted due to compilation errors.
########
}
$joe = 1 ;
EXPECT
-Global symbol "$joe" requires explicit package name at - line 6.
+Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 6.
Execution of - aborted due to compilation errors.
########
require "./abc";
EXPECT
Variable "$joe" is not imported at ./abc line 2.
-Global symbol "$joe" requires explicit package name at ./abc line 2.
+Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at ./abc line 2.
Compilation failed in require at - line 2.
########
require "./abc";
EXPECT
Variable "$jòè" is not imported at ./abc line 4.
-Global symbol "$jòè" requires explicit package name at ./abc line 4.
+Global symbol "$jòè" requires explicit package name (did you forget to declare "my $jòè"?) at ./abc line 4.
Compilation failed in require at - line 4.
########
use abc;
EXPECT
Variable "$joe" is not imported at abc.pm line 2.
-Global symbol "$joe" requires explicit package name at abc.pm line 2.
+Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at abc.pm line 2.
Compilation failed in require at - line 2.
BEGIN failed--compilation aborted at - line 2.
########
use abc;
EXPECT
Variable "$jòè" is not imported at abc.pm line 4.
-Global symbol "$jòè" requires explicit package name at abc.pm line 4.
+Global symbol "$jòè" requires explicit package name (did you forget to declare "my $jòè"?) at abc.pm line 4.
Compilation failed in require at - line 4.
BEGIN failed--compilation aborted at - line 4.
########
--FILE--
use abc;
EXPECT
-Global symbol "$f" requires explicit package name at abc.pm line 3.
-Global symbol "$k" requires explicit package name at abc.pm line 3.
-Global symbol "$g" requires explicit package name at abc.pm line 4.
-Global symbol "$l" requires explicit package name at abc.pm line 4.
-Global symbol "$c" requires explicit package name at abc.pm line 5.
-Global symbol "$h" requires explicit package name at abc.pm line 5.
-Global symbol "$m" requires explicit package name at abc.pm line 5.
-Global symbol "$d" requires explicit package name at abc.pm line 6.
-Global symbol "$i" requires explicit package name at abc.pm line 6.
-Global symbol "$n" requires explicit package name at abc.pm line 6.
-Global symbol "$e" requires explicit package name at abc.pm line 7.
-Global symbol "$j" requires explicit package name at abc.pm line 7.
-Global symbol "$o" requires explicit package name at abc.pm line 7.
-Global symbol "$p" requires explicit package name at abc.pm line 8.
+Global symbol "$f" requires explicit package name (did you forget to declare "my $f"?) at abc.pm line 3.
+Global symbol "$k" requires explicit package name (did you forget to declare "my $k"?) at abc.pm line 3.
+Global symbol "$g" requires explicit package name (did you forget to declare "my $g"?) at abc.pm line 4.
+Global symbol "$l" requires explicit package name (did you forget to declare "my $l"?) at abc.pm line 4.
+Global symbol "$c" requires explicit package name (did you forget to declare "my $c"?) at abc.pm line 5.
+Global symbol "$h" requires explicit package name (did you forget to declare "my $h"?) at abc.pm line 5.
+Global symbol "$m" requires explicit package name (did you forget to declare "my $m"?) at abc.pm line 5.
+Global symbol "$d" requires explicit package name (did you forget to declare "my $d"?) at abc.pm line 6.
+Global symbol "$i" requires explicit package name (did you forget to declare "my $i"?) at abc.pm line 6.
+Global symbol "$n" requires explicit package name (did you forget to declare "my $n"?) at abc.pm line 6.
+Global symbol "$e" requires explicit package name (did you forget to declare "my $e"?) at abc.pm line 7.
+Global symbol "$j" requires explicit package name (did you forget to declare "my $j"?) at abc.pm line 7.
+Global symbol "$o" requires explicit package name (did you forget to declare "my $o"?) at abc.pm line 7.
+Global symbol "$p" requires explicit package name (did you forget to declare "my $p"?) at abc.pm line 8.
Illegal binary digit '2' at abc.pm line 8, at end of line
abc.pm has too many errors.
Compilation failed in require at - line 1.
print STDERR $@;
$joe = 1 ;
EXPECT
-Global symbol "$joe" requires explicit package name at - line 6.
+Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 6.
Execution of - aborted due to compilation errors.
########
print STDERR $@;
$joe = 1 ;
EXPECT
-Global symbol "$joe" requires explicit package name at - line 5.
-Global symbol "$joe" requires explicit package name at - line 8.
+Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 5.
+Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 8.
Execution of - aborted due to compilation errors.
########
$joe = 1 ;
EXPECT
Variable "$joe" is not imported at - line 9.
-Global symbol "$joe" requires explicit package name at - line 9.
+Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 9.
Execution of - aborted due to compilation errors.
########
$jòè = 1 ;
EXPECT
Variable "$jòè" is not imported at - line 11.
-Global symbol "$jòè" requires explicit package name at - line 11.
+Global symbol "$jòè" requires explicit package name (did you forget to declare "my $jòè"?) at - line 11.
Execution of - aborted due to compilation errors.
########
$joe = 1 ;
]; print STDERR $@;
EXPECT
-Global symbol "$joe" requires explicit package name at (eval 1) line 3.
+Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at (eval 1) line 3.
########
# Check scope of pragma with eval
$joe = 1 ;
'; print STDERR $@ ;
EXPECT
-Global symbol "$joe" requires explicit package name at (eval 1) line 2.
+Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at (eval 1) line 2.
########
# Check scope of pragma with eval
'; print STDERR $@;
$joe = 1 ;
EXPECT
-Global symbol "$joe" requires explicit package name at - line 8.
+Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 8.
Execution of - aborted due to compilation errors.
########
print $@;
print "ok 2\n" unless defined $ret;
EXPECT
-Global symbol "$x" requires explicit package name at (eval 1) line 1.
+Global symbol "$x" requires explicit package name (did you forget to declare "my $x"?) at (eval 1) line 1.
ok 1
-Global symbol "$x" requires explicit package name at (eval 2) line 1.
+Global symbol "$x" requires explicit package name (did you forget to declare "my $x"?) at (eval 2) line 1.
ok 2
########
$fred ;
EXPECT
Variable "$fred" is not imported at - line 8.
-Global symbol "$fred" requires explicit package name at - line 8.
+Global symbol "$fred" requires explicit package name (did you forget to declare "my $fred"?) at - line 8.
Execution of - aborted due to compilation errors.
########
$frèd ;
EXPECT
Variable "$frèd" is not imported at - line 10.
-Global symbol "$frèd" requires explicit package name at - line 10.
+Global symbol "$frèd" requires explicit package name (did you forget to declare "my $frèd"?) at - line 10.
Execution of - aborted due to compilation errors.
########
no warnings;
"@i_like_crackers";
EXPECT
-Global symbol "@i_like_crackers" requires explicit package name at - line 7.
+Global symbol "@i_like_crackers" requires explicit package name (did you forget to declare "my @i_like_crackers"?) at - line 7.
Execution of - aborted due to compilation errors.
########
use strict 'vars';
@k = <$k>;
EXPECT
-Global symbol "@k" requires explicit package name at - line 4.
-Global symbol "$k" requires explicit package name at - line 4.
+Global symbol "@k" requires explicit package name (did you forget to declare "my @k"?) at - line 4.
+Global symbol "$k" requires explicit package name (did you forget to declare "my $k"?) at - line 4.
Execution of - aborted due to compilation errors.
########
# [perl #26910] hints not propagated into (?{...})
use strict 'vars';
qr/(?{$foo++})/;
EXPECT
-Global symbol "$foo" requires explicit package name at - line 3.
+Global symbol "$foo" requires explicit package name (did you forget to declare "my $foo"?) at - line 3.
Execution of - aborted due to compilation errors.
########
# Regex compilation errors weren't UTF-8 clean.
use open qw( :utf8 :std );
qr/(?{$fòò++})/;
EXPECT
-Global symbol "$fòò" requires explicit package name at - line 5.
+Global symbol "$fòò" requires explicit package name (did you forget to declare "my $fòò"?) at - line 5.
Execution of - aborted due to compilation errors.
########
# [perl #73712] 'Variable is not imported' should be suppressible
########
# mg.c
+use warnings 'signal' ;
+if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {
+ print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit;
+}
+$|=1;
+$SIG{__WARN__} = sub { warn shift =~ s/\0/\\0/rugs };
+$SIG{"INT"} = "fr\0d"; kill "INT",$$;
+EXPECT
+SIGINT handler "fr\0d" not defined.
+########
+# mg.c
+use warnings 'signal' ;
+use open ":std", ":utf8";
+use utf8;
+if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {
+ print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit;
+}
+$|=1;
+$SIG{"INT"} = "프레드"; kill "INT",$$;
+EXPECT
+SIGINT handler "프레드" not defined.
+########
+# mg.c
use warnings 'uninitialized';
'foo' =~ /(foo)/;
oct $3;
regcomp.c These tests have been moved to t/re/reg_mesg.t
- except for those that explicitly test line numbers.
+ except for those that explicitly test line numbers
+ and those that don't have a <-- HERE in them.
__END__
use warnings 'regexp';
"a" =~ /a$r/; # warning should come from this line
EXPECT
\b+ matches null string many times in regex; marked by <-- HERE in m/\b+ <-- HERE / at - line 3.
+########
+# regcomp.c
+use warnings 'digit' ;
+my $a = qr/\o{1238456}\x{100}/;
+my $a = qr/[\o{6548321}]\x{100}/;
+no warnings 'digit' ;
+my $a = qr/\o{1238456}\x{100}/;
+my $a = qr/[\o{6548321}]\x{100}/;
+EXPECT
+Non-octal character '8'. Resolved as "\o{123}" at - line 3.
+Non-octal character '8'. Resolved as "\o{654}" at - line 4.
+########
+# regcomp.c.c
+use warnings;
+$a = qr/\c,/;
+$a = qr/[\c,]/;
+no warnings 'syntax';
+$a = qr/\c,/;
+$a = qr/[\c,]/;
+EXPECT
+"\c," is more clearly written simply as "l" at - line 3.
+"\c," is more clearly written simply as "l" at - line 4.
$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 "a_c" isn't numeric in preincrement (++) at - line 5.
+Argument "(?^:abc)" isn't numeric in preincrement (++) at - line 6.
Argument "123x" isn't numeric in preincrement (++) at - line 7.
Argument "123e" isn't numeric in preincrement (++) at - line 8.
print for keys %+; # should not warn
EXPECT
########
-# toke.c
+# toke.c [This does not warn any more.]
sub fred {};
-fred ;
sub hank : lvalue {$_}
--hank; # This should *not* warn [perl #77240]
EXPECT
-Ambiguous use of -fred resolved as -&fred() at - line 3.
########
-# toke.c
+# toke.c [This does not warn any more.]
$^W = 0 ;
sub fred {} ;
-fred ;
}
-fred ;
EXPECT
-Ambiguous use of -fred resolved as -&fred() at - line 4.
-Ambiguous use of -fred resolved as -&fred() at - line 9.
-Ambiguous use of -fred resolved as -&fred() at - line 11.
########
-# toke.c
+# toke.c [This does not warn any more.]
use utf8;
use open qw( :utf8 :std );
sub frèd {};
-frèd ;
EXPECT
-Ambiguous use of -frèd resolved as -&frèd() at - line 5.
########
-# toke.c
+# toke.c [This does not warn any more.]
$^W = 0 ;
use utf8;
use open qw( :utf8 :std );
}
-frèd ;
EXPECT
-Ambiguous use of -frèd resolved as -&frèd() at - line 6.
-Ambiguous use of -frèd resolved as -&frèd() at - line 11.
-Ambiguous use of -frèd resolved as -&frèd() at - line 13.
########
-# toke.c
+# toke.c [This does not warn any more.]
use utf8;
use open qw( :utf8 :std );
sub ᒍᒘᒊ {};
-ᒍᒘᒊ ;
EXPECT
-Ambiguous use of -ᒍᒘᒊ resolved as -&ᒍᒘᒊ() at - line 5.
########
-# toke.c
+# toke.c [This does not warn any more.]
$^W = 0 ;
use utf8;
use open qw( :utf8 :std );
}
-ᒍᒘᒊ ;
EXPECT
-Ambiguous use of -ᒍᒘᒊ resolved as -&ᒍᒘᒊ() at - line 6.
-Ambiguous use of -ᒍᒘᒊ resolved as -&ᒍᒘᒊ() at - line 11.
-Ambiguous use of -ᒍᒘᒊ resolved as -&ᒍᒘᒊ() at - line 13.
########
# toke.c
open FOO || time;
$x->();
EXPECT
Undefined subroutine called at - line 4.
+########
+# NAME anon constant clobbering __ANON__
+sub __ANON__ { "42\n" }
+print __ANON__;
+sub(){3};
+EXPECT
+42
+########
+# NAME undef &anon giving it a freed GV
+$_ = sub{};
+delete $::{__ANON__};
+undef &$_; # SvREFCNT_dec + inc on a GV with a refcnt of 1
+ # so now SvTYPE(CvGV(anon)) is 0xff == freed
+if (!eval { require B }) { # miniperl, presumably
+ print "__ANON__\n";
+} else {
+ print B::svref_2object($_)->GV->NAME, "\n";
+}
+EXPECT
+__ANON__
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ require './test.pl';
+ set_up_inc('../lib');
}
require Tie::Array;
package main;
-require './test.pl';
plan(tests => 40);
# Helper function to check the typical error message.
BEGIN {
chdir 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 7;
sub foo { @c = caller(0) }
my $fooref = delete $::{foo};
$fooref -> ();
-is( $c[3], "main::__ANON__", "deleted subroutine name" );
+is( $c[3], "main::foo", "deleted subroutine name" );
ok( $c[4], "hasargs true with deleted sub" );
BEGIN {
sub foo2 { f() }
my $fooref2 = delete $::{foo2};
$fooref2 -> ();
-is( $c[3], "main::__ANON__", "deleted subroutine name" );
+is( $c[3], "main::foo2", "deleted subroutine name" );
ok( $c[4], "hasargs true with deleted sub" );
# See if caller() returns the correct warning mask
#!./perl -w
BEGIN {
+ # We really want to know if chdir is working, as the build process will
+ # all go wrong if it is not. So avoid clearing @INC under miniperl.
+ @INC = () if defined &DynaLoader::boot_DynaLoader;
+
# We're not going to chdir() into 't' because we don't know if
# chdir() works! Instead, we'll hedge our bets and put both
# possibilities into @INC.
- @INC = qw(t . lib ../lib);
+ unshift @INC, qw(t . lib ../lib);
require "test.pl";
- # Really want to know if chdir is working, as the build process will all go
- # wrong if it is not.
- if (is_miniperl() && !eval {require File::Spec::Functions; 1}) {
- push @INC, qw(dist/Cwd/lib dist/Cwd ../dist/Cwd/lib ../dist/Cwd);
- }
plan(tests => 48);
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use Config;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
+ @INC = qw(. ../lib ../dist/if);
require "test.pl";
$^P |= 0x100;
}
}
if ($hpcode) {
$tests ++;
+ # __FILE__ won’t fold with warnings on, and then we get
+ # ‘(eval 21)’ vs ‘(eval 22)’.
+ no warnings 'numeric';
$core = $bd->coderef2text(eval $hpcode =~ s/my/CORE::/r or die);
$my = $bd->coderef2text(eval $hpcode or die);
is $my, $core, "precedence of CORE::$word without parens";
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan(tests => 132);
#!./perl
+# Simple tests for the basic math functions.
+
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
-plan tests => 16;
+use Config;
+
+plan tests => 31;
# compile time evaluation
+eval { $s = sqrt(-1) }; # Kind of compile time.
+like($@, qr/sqrt of -1/, 'compile time sqrt(-1) fails');
+
+$s = sqrt(0);
+is($s, 0, 'compile time sqrt(0)');
+
+$s = sqrt(1);
+is($s, 1, 'compile time sqrt(1)');
+
$s = sqrt(2);
is(substr($s,0,5), '1.414', 'compile time sqrt(2) == 1.414');
+$s = exp(0);
+is($s, 1, 'compile time exp(0) == 1');
+
$s = exp(1);
is(substr($s,0,7), '2.71828', 'compile time exp(1) == e');
+eval { $s = log(0) }; # Kind of compile time.
+like($@, qr/log of 0/, 'compile time log(0) fails');
+
+$s = log(1);
+is($s, 0, 'compile time log(1) == 0');
+
+$s = log(2);
+is(substr($s,0,5), '0.693', 'compile time log(2)');
+
cmp_ok(exp(log(1)), '==', 1, 'compile time exp(log(1)) == 1');
+cmp_ok(round(atan2(1, 2)), '==', '0.463647609', "atan2(1, 2)");
+
# run time evaluation
+$x0 = 0;
$x1 = 1;
$x2 = 2;
+
+eval { $s = sqrt(-$x1) };
+like($@, qr/sqrt of -1/, 'run time sqrt(-1) fails');
+
+$s = sqrt($x0);
+is($s, 0, 'run time sqrt(0)');
+
+$s = sqrt($x1);
+is($s, 1, 'run time sqrt(1)');
+
$s = sqrt($x2);
is(substr($s,0,5), '1.414', 'run time sqrt(2) == 1.414');
+$s = exp($x0);
+is($s, 1, 'run time exp(0) = 1');
+
$s = exp($x1);
is(substr($s,0,7), '2.71828', 'run time exp(1) = e');
+eval { $s = log($x0) };
+like($@, qr/log of 0/, 'run time log(0) fails');
+
+$s = log($x1);
+is($s, 0, 'compile time log(1) == 0');
+
+$s = log($x2);
+is(substr($s,0,5), '0.693', 'run time log(2)');
+
cmp_ok(exp(log($x1)), '==', 1, 'run time exp(log(1)) == 1');
-# tests for transcendental functions
+# NOTE: do NOT test the trigonometric functions at [+-]Pi
+# and expect to get exact results like 0, 1, -1, because
+# you may not be able to feed them exactly [+-]Pi given
+# all the variations of different long doubles.
-my $pi = 3.1415926535897931160;
-my $pi_2 = 1.5707963267948965580;
+my $pi_2 = 1.5707963267949;
sub round {
my $result = shift;
# sin() tests
cmp_ok(sin(0), '==', 0.0, 'sin(0) == 0');
-cmp_ok(round(sin($pi)), '==', 0.0, 'sin(pi) == 0');
-cmp_ok(round(sin(-1 * $pi)), '==', 0.0, 'sin(-pi) == 0');
-cmp_ok(round(sin($pi_2)), '==', 1.0, 'sin(pi/2) == 1');
-cmp_ok(round(sin(-1 * $pi_2)), '==', -1.0, 'sin(-pi/2) == -1');
+cmp_ok(abs(sin($pi_2) - 1), '<', 1e-9, 'sin(pi/2) == 1');
+cmp_ok(abs(sin(-1 * $pi_2) - -1), '<', 1e-9, 'sin(-pi/2) == -1');
+
+cmp_ok(round(sin($x1)), '==', '0.841470985', "sin(1)");
# cos() tests
cmp_ok(cos(0), '==', 1.0, 'cos(0) == 1');
-cmp_ok(round(cos($pi)), '==', -1.0, 'cos(pi) == -1');
-cmp_ok(round(cos(-1 * $pi)), '==', -1.0, 'cos(-pi) == -1');
-cmp_ok(round(cos($pi_2)), '==', 0.0, 'cos(pi/2) == 0');
-cmp_ok(round(cos(-1 * $pi_2)), '==', 0.0, 'cos(-pi/2) == 0');
-
-# atan2() tests were removed due to differing results from calls to
-# atan2() on various OS's and architectures. See perlport.pod for
-# more information.
+cmp_ok(abs(cos($pi_2)), '<', 1e-9, 'cos(pi/2) == 0');
+cmp_ok(abs(cos(-1 * $pi_2)), '<', 1e-9, 'cos(-pi/2) == 0');
+
+cmp_ok(round(cos($x1)), '==', '0.540302306', "cos(1)");
+
+cmp_ok(round(atan2($x1, $x2)), '==', '0.463647609', "atan2($x1, $x2)");
+
+# atan2() tests testing with -0.0, 0.0, -1.0, 1.0 were removed due to
+# differing results from calls to atan2() on various OS's and
+# architectures. See perlport.pod for more information.
+
+SKIP: {
+ unless ($Config{usequadmath}) {
+ skip "need usequadmath", 1;
+ }
+ # For quadmath we have a known precision.
+ is(sqrt(2), '1.4142135623730950488016887242097', "quadmath sqrt");
+}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc(qw '../lib ../cpan/Perl-OSType/lib');
}
plan(tests => 53 + 27*14);
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use warnings;
-plan( tests => 267 );
+plan( tests => 271 );
# type coercion on assignment
$foo = 'foo';
is prototype "yarrow", "", 'const list has "" prototype';
is eval "yarrow", 3, 'const list in scalar cx returns length';
+$::{borage} = \&ok;
+eval 'borage("sub ref in stash")' or fail "sub ref in stash";
+
{
use vars qw($glook $smek $foof);
# Check reference assignment isn't affected by the SV type (bug #38439)
format =
.
-foreach my $value ({1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
+foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) {
# *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
# IO::Handle, which isn't what we want.
my $type = $value;
"Undefined subroutine &main::foo called at -e line 1.\n",
"gv_try_downgrade does not anonymise CVs referenced elsewhere";
+package glob_constant_test {
+ sub foo { 42 }
+ use constant bar => *foo;
+ BEGIN { undef *foo }
+ ::is eval { bar->() }, eval { &{+bar} },
+ 'glob_constant->() is not mangled at compile time';
+ ::is "$@", "", 'no error from eval { &{+glob_constant} }';
+}
+
+{
+ my $free2;
+ local $SIG{__WARN__} = sub { ++$free2 if shift =~ /Attempt to free/ };
+ my $handleref;
+ my $proxy = \$handleref;
+ open $$proxy, "TEST";
+ delete $::{*$handleref{NAME}}; # delete *main::_GEN_xxx
+ undef $handleref;
+ is $free2, undef,
+ 'no double free because of bad rv2gv/newGVgen refcounting';
+}
+
# Look away, please.
# This violates perl's internal structures by fiddling with stashes in a
# way that should never happen, but perl should not start trying to free
eval { $y->() };
pass "No crash due to CvGV pointing to glob copy in the stash";
+# Aliasing should disable no-common-vars optimisation.
+{
+ *x = *y;
+ $x = 3;
+ ($x, my $z) = (1, $y);
+ is $z, 3, 'list assignment after aliasing [perl #89646]';
+}
+
+
__END__
Perl
Rules
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
BEGIN {
chdir 't' if -d 't';
+ unshift @INC, '../lib';
require './test.pl';
- eval '0x0p0';
- print "# $@\n";
}
plan(tests => 79);
# Underbars.
is(0xa_b.c_dp+1_2, 703696);
-# Note that the hexfloat representation is not unique
-# since the exponent can be shifted: no different from
-# 3e4 cf 30e3 cf 30000.
+# Note that the hexfloat representation is not unique since the
+# exponent can be shifted, and the hexdigits with it: this is no
+# different from 3e4 cf 30e3 cf 30000. The shifting of the hexdigits
+# makes it look stranger, though: 0xap1 == 0x5p2.
# Needs to use within() instead of is() because of long doubles.
-within(0x1.999999999999ap-4, 0.1, 1e-9);
-within(0x3.3333333333333p-5, 0.1, 1e-9);
-within(0xc.ccccccccccccdp-7, 0.1, 1e-9);
+within(0x1.99999999999ap-4, 0.1, 1e-9);
+within(0x3.333333333333p-5, 0.1, 1e-9);
+within(0xc.cccccccccccdp-7, 0.1, 1e-9);
my $warn;
$found = 1;
last;
}
-die "Could not find a value which overflows the mantissa" unless $found;
+
+ok($found, "found a NV value which overflows the mantissa");
# these will segfault if they fail
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
require './test.pl';
+ set_up_inc('../lib');
}
use Config;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
- require './test.pl'; require './charset_tools.pl';
+ require './test.pl';
+ set_up_inc('../lib');
+ require './charset_tools.pl';
}
use strict;
--- /dev/null
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+use strict;
+
+use Config;
+
+BEGIN {
+ if ($^O eq 'aix' && $Config{uselongdouble}) {
+ # FWIW: NaN actually seems to be working decently,
+ # but Inf is completely broken (e.g. Inf + 0 -> NaN).
+ skip_all "$^O with long doubles does not have sane inf/nan";
+ }
+}
+
+my $PInf = "Inf" + 0;
+my $NInf = "-Inf" + 0;
+my $NaN = "NaN" + 0;
+
+my @PInf = ("Inf", "inf", "INF", "+Inf",
+ "Infinity", "INFINITE",
+ "1.#INF", "1#INF");
+my @NInf = map { "-$_" } grep { ! /^\+/ } @PInf;
+
+my @NaN = ("NAN", "nan", "qnan", "SNAN", "NanQ", "NANS",
+ "1.#QNAN", "+1#SNAN", "-1.#NAN", "1#IND",
+ "NaN123", "NAN(123)", "nan%",
+ "nanonano"); # RIP, Robin Williams.
+
+my @num_fmt = qw(e f g a d u o b x p);
+
+my $inf_tests = 13 + @num_fmt + 8 + 3 * @PInf + 3 * @NInf + 5 + 3;
+my $nan_tests = 8 + @num_fmt + 4 + 2 * @NaN + 3;
+
+my $infnan_tests = 4;
+
+plan tests => $inf_tests + $nan_tests + $infnan_tests;
+
+my $has_inf;
+my $has_nan;
+
+SKIP: {
+ if ($PInf == 0 && $NInf == 0) {
+ skip $inf_tests, "no infinity found";
+ }
+
+ $has_inf = 1;
+
+ cmp_ok($PInf, '>', 0, "positive infinity");
+ cmp_ok($NInf, '<', 0, "negative infinity");
+
+ cmp_ok($PInf, '>', $NInf, "positive > negative");
+ cmp_ok($NInf, '==', -$PInf, "negative == -positive");
+ cmp_ok(-$NInf, '==', $PInf, "--negative == positive");
+
+ is($PInf, "Inf", "$PInf value stringifies as Inf");
+ is($NInf, "-Inf", "$NInf value stringifies as -Inf");
+
+ cmp_ok($PInf * 2, '==', $PInf, "twice Inf is Inf");
+ cmp_ok($PInf / 2, '==', $PInf, "half of Inf is Inf");
+
+ cmp_ok($PInf + 1, '==', $PInf, "Inf + one is Inf");
+ cmp_ok($NInf + 1, '==', $NInf, "-Inf + one is -Inf");
+
+ is(sprintf("%g", $PInf), "Inf", "$PInf sprintf %g is Inf");
+ is(sprintf("%a", $PInf), "Inf", "$PInf sprintf %a is Inf");
+
+ for my $f (@num_fmt) {
+ is(sprintf("%$f", $PInf), "Inf", "$PInf sprintf %$f is Inf");
+ }
+
+ {
+ local $^W = 0;
+
+ is(sprintf("%c", $PInf), chr(0xFFFD), "$PInf sprintf %c is Inf");
+ is(chr($PInf), chr(0xFFFD), "$PInf chr() is U+FFFD");
+
+ is(sprintf("%c", $NInf), chr(0xFFFD), "$NInf sprintf %c is Inf");
+ is(chr($NInf), chr(0xFFFD), "$NInf chr() is U+FFFD");
+
+ is(pack('C', $PInf), chr(0xFF), "$PInf pack C is 0xFF byte");
+ is(pack('c', $PInf), chr(0xFF), "$PInf pack c is 0xFF byte");
+
+ is(pack('C', $NInf), chr(0xFF), "$NInf pack C is 0xFF byte");
+ is(pack('c', $NInf), chr(0xFF), "$NInf pack c is 0xFF byte");
+ }
+
+ for my $i (@PInf) {
+ cmp_ok($i + 0 , '==', $PInf, "$i is +Inf");
+ cmp_ok($i, '>', 0, "$i is positive");
+ is("@{[$i+0]}", "Inf", "$i value stringifies as Inf");
+ }
+
+ for my $i (@NInf) {
+ cmp_ok($i + 0, '==', $NInf, "$i is -Inf");
+ cmp_ok($i, '<', 0, "$i is negative");
+ is("@{[$i+0]}", "-Inf", "$i value stringifies as -Inf");
+ }
+
+ is($PInf + $PInf, $PInf, "+inf plus +inf is +inf");
+ is($NInf + $NInf, $NInf, "-inf plus -inf is -inf");
+
+ is(1/$PInf, 0, "one per +Inf is zero");
+ is(1/$NInf, 0, "one per -Inf is zero");
+
+ SKIP: {
+ my $here = "$^O $Config{osvers}";
+ if ($here =~ /^hpux 10/) {
+ skip "$here: pow doesn't generate Inf", 1;
+ }
+ is(9**9**9, $PInf, "9**9**9 is Inf");
+ }
+}
+
+SKIP: {
+ my @FInf = qw(Info Infiniti Infinityz);
+ if ($Config{usequadmath}) {
+ skip "quadmath strtoflt128() accepts false infinities", scalar @FInf;
+ }
+ # Silence "isn't numeric in addition", that's kind of the point.
+ local $^W = 0;
+ for my $i (@FInf) {
+ cmp_ok("$i" + 0, '==', 0, "false infinity $i");
+ }
+}
+
+SKIP: {
+ if ($NaN == 0) {
+ skip $nan_tests, "no nan found";
+ }
+
+ $has_nan = 1;
+
+ cmp_ok($NaN, '!=', $NaN, "NaN is NaN numerically (by not being NaN)");
+ ok($NaN eq $NaN, "NaN is NaN stringifically");
+
+ is("$NaN", "NaN", "$NaN value stringifies as NaN");
+
+ is("+NaN" + 0, "NaN", "+NaN is NaN");
+ is("-NaN" + 0, "NaN", "-NaN is NaN");
+
+ is($NaN * 2, $NaN, "twice NaN is NaN");
+ is($NaN / 2, $NaN, "half of NaN is NaN");
+
+ is($NaN + 1, $NaN, "NaN + one is NaN");
+
+ for my $f (@num_fmt) {
+ is(sprintf("%$f", $NaN), "NaN", "$NaN sprintf %$f is NaN");
+ }
+
+ {
+ local $^W = 0;
+
+ is(sprintf("%c", $NaN), chr(0xFFFD), "$NaN sprintf %c is Inf");
+ is(chr($NaN), chr(0xFFFD), "$NaN chr() is U+FFFD");
+
+ is(pack('C', $NaN), chr(0xFF), "$NaN pack C is 0xFF byte");
+ is(pack('c', $NaN), chr(0xFF), "$NaN pack c is 0xFF");
+ }
+
+ for my $i (@NaN) {
+ cmp_ok($i + 0, '!=', $i + 0, "$i is NaN numerically (by not being NaN)");
+ is("@{[$i+0]}", "NaN", "$i value stringifies as NaN");
+ }
+
+ # is() okay with $NaN because it uses eq.
+ is($NaN * 0, $NaN, "NaN times zero is NaN");
+ is($NaN * 2, $NaN, "NaN times two is NaN");
+
+ SKIP: {
+ my $here = "$^O $Config{osvers}";
+ if ($here =~ /^hpux 10/) {
+ skip "$here: pow doesn't generate Inf, so sin(Inf) won't happen", 1;
+ }
+ is(sin(9**9**9), $NaN, "sin(9**9**9) is NaN");
+ }
+}
+
+SKIP: {
+ unless ($has_inf && $has_nan) {
+ skip $infnan_tests, "no both Inf and Nan";
+ }
+
+ # is() okay with $NaN because it uses eq.
+ is($PInf * 0, $NaN, "Inf times zero is NaN");
+ is($PInf * $NaN, $NaN, "Inf times NaN is NaN");
+ is($PInf + $NaN, $NaN, "Inf plus NaN is NaN");
+ is($PInf - $PInf, $NaN, "Inf minus inf is NaN");
+}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
# use strict;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
# use strict;
BEGIN {
chdir 't';
- @INC = '../lib';
+ require './test.pl';
+ set_up_inc('../lib');
require Config; import Config;
- require './test.pl'; require './charset_tools.pl';
+ skip_all_without_unicode_tables();
+ require './charset_tools.pl';
require './loc_tools.pl'; # Contains find_utf8_ctype_locale()
}
BEGIN {
chdir 't' if -d 't';
require './test.pl';
- @INC = '../lib';
+ set_up_inc('../lib');
}
plan (tests => 41);
BEGIN {
chdir 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
*bar::is = *is;
*bar::like = *like;
}
-plan 120;
+plan 143;
# -------------------- Errors with feature disabled -------------------- #
my $y = if if if;
is $y, 42, 'our subs from other packages override all keywords';
}
+# Interaction with ‘use constant’
+{
+ our sub const; # symtab now has an undefined CV
+ BEGIN { delete $::{const} } # delete symtab entry; pad entry still exists
+ use constant const => 3; # symtab now has a scalar ref
+ # inlining this used to fail an assertion (parentheses necessary):
+ is(const, 3, 'our sub pointing to "use constant" constant');
+}
+# our sub and method confusion
+sub F::h { 4242 }
+{
+ my $called;
+ our sub h { ++$called; 4343 };
+ is((h F),4242, 'our sub symbol translation does not affect meth names');
+ undef $called;
+ print "#";
+ print h F; # follows a different path through yylex to intuit_method
+ print "\n";
+ is $called, undef, 'our sub symbol translation & meth names after print'
+}
+our sub j;
+is j
+ =>, 'j', 'name_of_our_sub <newline> => is parsed properly';
+sub _cmp { $a cmp $b }
+sub bar::_cmp { $b cmp $a }
+{
+ package bar;
+ our sub _cmp;
+ package main;
+ is join(" ", sort _cmp split //, 'oursub'), 'u u s r o b', 'sort our_sub'
+}
# -------------------- state -------------------- #
),
qr/syntax error/,
'referencing a state sub after a syntax error does not crash';
+{
+ state $stuff;
+ package A {
+ state sub foo{ $stuff .= our $AUTOLOAD }
+ *A::AUTOLOAD = \&foo;
+ }
+ A::bar();
+ is $stuff, 'A::bar', 'state sub assigned to *AUTOLOAD can autoload';
+}
+{
+ state sub quire{qr "quires"}
+ package o { use overload qr => \&quire }
+ ok "quires" =~ bless([], o::), 'state sub used as overload method';
+}
+{
+ state sub foo;
+ *cvgv = \&foo;
+ local *cvgv2 = *cvgv;
+ eval 'sub cvgv2 {42}'; # uses the stub already present
+ is foo, 42, 'defining state sub body via package sub declaration';
+}
+{
+ local $ENV{PERL5DB} = 'sub DB::DB{}';
+ is(
+ runperl(
+ switches => [ '-d' ],
+ progs => [ split "\n",
+ 'use feature qw - lexical_subs state -;
+ no warnings q-experimental::lexical_subs-;
+ sub DB::sub{ print qq|4\n|; goto $DB::sub }
+ state sub foo {print qq|2\n|}
+ foo();
+ '
+ ],
+ stderr => 1
+ ),
+ "4\n2\n",
+ 'state subs and DB::sub under -d'
+ );
+ is(
+ runperl(
+ switches => [ '-d' ],
+ progs => [ split "\n",
+ 'use feature qw - lexical_subs state -;
+ no warnings q-experimental::lexical_subs-;
+ sub DB::goto{ print qq|4\n|; $_ = $DB::sub }
+ state sub foo {print qq|2\n|}
+ $^P|=0x80;
+ sub { goto &foo }->();
+ print $_ == \&foo ? qq|ok\n| : qq|$_\n|;
+ '
+ ],
+ stderr => 1
+ ),
+ "4\n2\nok\n",
+ 'state subs and DB::goto under -d'
+ );
+}
+# This used to fail an assertion, but only as a standalone script
+is runperl(switches => ['-lXMfeature=:all'],
+ prog => 'state sub x {}; undef &x; print defined &x',
+ stderr => 1), "\n", 'undefining state sub';
+{
+ state sub x { is +(caller 0)[3], 'x', 'state sub name in caller' }
+ x
+}
+{
+ state sub _cmp { $b cmp $a }
+ is join(" ", sort _cmp split //, 'lexsub'), 'x u s l e b',
+ 'sort state_sub LIST'
+}
+{
+ state sub handel { "" }
+ print handel, "ok ", curr_test(),
+ " - no 'No comma allowed' after state sub\n";
+ curr_test(curr_test()+1);
+}
# -------------------- my -------------------- #
),
qr/syntax error/,
'referencing a my sub after a syntax error does not crash';
+{
+ state $stuff;
+ package A {
+ my sub foo{ $stuff .= our $AUTOLOAD }
+ *A::AUTOLOAD = \&foo;
+ }
+ A::bar();
+ is $stuff, 'A::bar', 'my sub assigned to *AUTOLOAD can autoload';
+}
+{
+ my sub quire{qr "quires"}
+ package mo { use overload qr => \&quire }
+ ok "quires" =~ bless([], mo::), 'my sub used as overload method';
+}
+{
+ my sub foo;
+ *mcvgv = \&foo;
+ local *mcvgv2 = *mcvgv;
+ eval 'sub mcvgv2 {42}'; # uses the stub already present
+ is foo, 42, 'defining my sub body via package sub declaration';
+}
+{
+ my sub foo;
+ *mcvgv3 = \&foo;
+ local *mcvgv4 = *mcvgv3;
+ eval 'sub mcvgv4 {42}'; # uses the stub already present
+ undef *mcvgv3; undef *mcvgv4; # leaves the pad with the only reference
+}
+# We would have crashed by now if it weren’t fixed.
+pass "pad taking ownership once more of packagified my-sub";
+
+{
+ local $ENV{PERL5DB} = 'sub DB::DB{}';
+ is(
+ runperl(
+ switches => [ '-d' ],
+ progs => [ split "\n",
+ 'use feature qw - lexical_subs state -;
+ no warnings q-experimental::lexical_subs-;
+ sub DB::sub{ print qq|4\n|; goto $DB::sub }
+ my sub foo {print qq|2\n|}
+ foo();
+ '
+ ],
+ stderr => 1
+ ),
+ "4\n2\n",
+ 'my subs and DB::sub under -d'
+ );
+}
+# This used to fail an assertion, but only as a standalone script
+is runperl(switches => ['-lXMfeature=:all'],
+ prog => 'my sub x {}; undef &x; print defined &x',
+ stderr => 1), "\n", 'undefining my sub';
+{
+ my sub x { is +(caller 0)[3], 'x', 'my sub name in caller' }
+ x
+}
+{
+ my sub _cmp { $b cmp $a }
+ is join(" ", sort _cmp split //, 'lexsub'), 'x u s l e b',
+ 'sort my_sub LIST'
+}
+{
+ my sub handel { "" }
+ print handel,"ok ",curr_test()," - no 'No comma allowed' after my sub\n";
+ curr_test(curr_test()+1);
+}
# -------------------- Interactions (and misc tests) -------------------- #
# argv[0] assignment and by calling prctl()
{
SKIP: {
- skip "We don't have prctl() here", 2 unless $Config{d_prctl_set_name};
+ skip "We don't have prctl() here, or we're on Android", 2 unless $Config{d_prctl_set_name} && $^O ne 'android';
# We don't really need these tests. prctl() is tested in the
# Kernel, but test it anyway for our sanity. If something doesn't
SKIP: {
skip("\$0 check only on Linux and FreeBSD", 2)
- unless $^O =~ /^(linux|freebsd)$/
+ unless $^O =~ /^(linux|android|freebsd)$/
&& open CMDLINE, "/proc/$$/cmdline";
chomp(my $line = scalar <CMDLINE>);
my $me = (split /\0/, $line)[0];
is $me, $0, 'altering $0 is effective (testing with /proc/)';
close CMDLINE;
+ skip("\$0 check with 'ps' only on Linux (but not Android) and FreeBSD", 1) if $^O eq 'android';
# perlbug #22811
my $mydollarzero = sub {
my($arg) = shift;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib lib);
+ @INC = qw(. ../lib lib ../dist/base/lib);
require "test.pl";
}
$ENV{'LC_ALL'} = 'C';
$ENV{LANGUAGE} = 'C'; # GNU locale extension
+sub errno_or_skip {
+ SKIP: {
+ if (is_miniperl && !eval { local $!; require Errno }) {
+ skip "Errno not built yet", 1;
+ }
+ eval "ok($_[0])";
+ }
+}
+
ok(mkdir('blurfl',0777));
ok(!mkdir('blurfl',0777));
-ok($!{EEXIST} || $! =~ /cannot move|exist|denied|unknown/i);
+errno_or_skip('$!{EEXIST} || $! =~ /cannot move|exist|denied|unknown/i');
ok(-d 'blurfl');
ok(rmdir('blurfl'));
ok(!rmdir('blurfl'));
-ok($!{ENOENT} || $! =~ /cannot find|such|exist|not found|not a directory|unknown/i);
+errno_or_skip('
+ $!{ENOENT}
+ || $! =~ /cannot find|such|exist|not found|not a directory|unknown/i
+');
ok(mkdir('blurfl'));
ok(rmdir('blurfl'));
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan 9;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc(qw '../lib ../cpan/Text-ParseWords/lib');
require Config; # load these before we mess with *CORE::GLOBAL::require
require 'Config_heavy.pl'; # since runperl will need them
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc(qw '../lib ../dist/Math-BigInt/lib');
}
# This is truth in an if statement, and could be a skip message
BEGIN {
chdir 't';
- @INC = '../lib';
+ @INC = qw '../lib ../cpan/version/lib';
require './test.pl';
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
@tests = split(/\n/, <<EOF);
BEGIN {
chdir 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 30;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 26;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
use warnings;
BEGIN {
chdir 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict;
use warnings;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
- require 'test.pl';
+ require './test.pl';
+ set_up_inc('../lib');
}
use warnings;
plan( tests => 182 );
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
-plan tests => 119;
+plan tests => 120;
$FS = ':';
# /^/ treated as /^/m
$_ = join ':', split /^/, "ab\ncd\nef\n";
-is($_, "ab\n:cd\n:ef\n");
+is($_, "ab\n:cd\n:ef\n","check that split /^/ is treated as split /^/m");
+
+$_ = join ':', split /\A/, "ab\ncd\nef\n";
+is($_, "ab\ncd\nef\n","check that split /\A/ is NOT treated as split /^/m");
# see if @a = @b = split(...) optimization works
@list1 = @list2 = split ('p',"a p b c p");
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ @INC = qw '../lib ../cpan/version/lib';
}
use warnings;
use version;
# IEEE 754 128-bit ("quadruple precision"), e.g. IA-64 (Itanium) in VMS
$Config{nvsize} == 16 &&
# 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f (LE), pack F is the NV
- # (compare this with "double-double")
(pack("F", 0.1) =~ /^\x9A\x99{6}/ || # LE
- pack("F", 0.1) =~ /\x99{6}x9A$/) # BE
+ pack("F", 0.1) =~ /\x99{6}\x9A$/) # BE
) {
@hexfloat = (
- [ '%a', '0', '0x1p-1' ],
+ [ '%a', '0', '0x0p+0' ],
[ '%a', '1', '0x1p+0' ],
[ '%a', '1.0', '0x1p+0' ],
[ '%a', '0.5', '0x1p-1' ],
} elsif (
# "double-double", two 64-bit doubles end to end
$Config{nvsize} == 16 &&
- # bf b9 99 99 99 99 99 9a 3c 59 99 99 99 99 99 9a (BE), pack F is the NV
- # (compare this with "quadruple precision")
- (pack("F", 0.1) =~ /^\x9A\x99{5}\x59\x3C/ || # LE
- pack("F", 0.1) =~ /\x3C\x59\x99{5}\x9A$/) # BE
+ # bf b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE), pack F is the NV
+ (pack("F", 0.1) =~ /^\x9A\x99{5}\x59\xBC/ || # LE
+ pack("F", 0.1) =~ /\xBC\x59\x99{5}\x9A$/) # BE
) {
- # XXX these values are probably slightly wrong, even if
- # the double-double extraction code gets fixed, the exact
- # truncation/rounding effects are unknown.
@hexfloat = (
- [ '%a', '0', '0x1p-1' ],
+ [ '%a', '0', '0x0p+0' ],
[ '%a', '1', '0x1p+0' ],
[ '%a', '1.0', '0x1p+0' ],
[ '%a', '0.5', '0x1p-1' ],
[ '%a', '0.25', '0x1p-2' ],
[ '%a', '0.75', '0x1.8p-1' ],
- [ '%a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ],
- [ '%a', '-1', '-0x1p+0' ],
- [ '%a', '-3.14', '-0x1.91eb851eb851eb851eb851eb852p+1' ],
- [ '%a', '0.1', '0x1.99999999999999999999999999ap-4' ],
- [ '%a', '1/7', '0x1.249249249249249249249249249p-3' ],
- [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcc908b2fb1366ea9p+0' ],
+ [ '%a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ],
+ [ '%a', '-1', '-0x0p+0' ],
+ [ '%a', '-3.14', '-0x1.91eb851eb851eb851eb851eb85p+1' ],
+ [ '%a', '0.1', '0x1.999999999999999999999999998p-4' ],
+ [ '%a', '1/7', '0x1.249249249249249249249249248p-3' ],
+ [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcc908b2fb1366ea8p+0' ],
[ '%a', 'exp(1)', '0x1.5bf0a8b1457695355fb8ac404e8p+1' ],
[ '%a', '2**-10', '0x1p-10' ],
[ '%a', '2**10', '0x1p+10' ],
- [ '%a', '1e-09', '0x1.12e0be826d694b2e62d01511f13p-30' ],
+ [ '%a', '1e-09', '0x1.12e0be826d694b2e62d01511f14p-30' ],
[ '%a', '1e9', '0x1.dcd65p+29' ],
[ '%#a', '1', '0x1.p+0' ],
[ '% a', '1', ' 0x1p+0' ],
[ '% a', '-1', '-0x1p+0' ],
- [ '%8a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ],
- [ '%13a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ],
- [ '%20a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ],
+ [ '%8a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ],
+ [ '%13a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ],
+ [ '%20a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ],
[ '%.4a', '3.14', '0x1.91ecp+1' ],
[ '%.5a', '3.14', '0x1.91eb8p+1' ],
[ '%.6a', '3.14', '0x1.91eb85p+1' ],
- [ '%.20a', '3.14', '0x1.91eb851eb851eb851eb8p+1' ],
+ [ '%.20a', '3.14', '0x1.91eb851eb851eb851eb8p+1' ],
[ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ],
- [ '%20.15a', '3.14', '0x1.91eb851eb851eb8p+1' ],
+ [ '%20.15a', '3.14', '0x1.91eb851eb851eb8p+1' ],
[ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ],
[ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ],
- [ '%30a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ],
- [ '%-30a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ],
- [ '%030a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ],
- [ '%-030a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ],
+ [ '%30a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ],
+ [ '%-30a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ],
+ [ '%030a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ],
+ [ '%-030a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ],
[ '%.40a', '3.14',
- '0x1.91eb851eb851eb851eb851eb8520000000000000p+1' ],
+ '0x1.91eb851eb851eb851eb851eb8500000000000000p+1' ],
- [ '%A', '3.14', '0X1.91EB851EB851EB851EB851EB852P+1' ],
+ [ '%A', '3.14', '0X1.91EB851EB851EB851EB851EB85P+1' ],
);
} else {
print "# no hexfloat tests\n";
my ($format, $arg, $expected) = @$t;
$arg = eval $arg;
my $result = sprintf($format, $arg);
- is($result, $expected, "'$format' '$arg' -> '$result' cf '$expected'");
+ my $ok = $result eq $expected;
+ unless ($ok) {
+ # It seems that there can be difference in the last bits:
+ # [perl #122578]
+ # got "0x1.5bf0a8b14576ap+1"
+ # expected "0x1.5bf0a8b145769p+1"
+ # (Android on ARM)
+ #
+ # Exact cause unknown but suspecting different fp rounding modes,
+ # (towards zero? towards +inf? towards -inf?) about which Perl
+ # is blissfully unaware.
+ #
+ # Try extracting one (or sometimes two) last mantissa
+ # hexdigits, and see if they differ in value by one.
+ my ($rh, $eh) = ($result, $expected);
+ sub extract_prefix {
+ ($_[0] =~ s/(-?0x[0-9a-fA-F]+\.)//) && return $1;
+ }
+ my $rp = extract_prefix($rh);
+ my $ep = extract_prefix($eh);
+ print "# rp = $rp, ep = $ep (rh $rh, eh $eh)\n";
+ if ($rp eq $ep) { # If prefixes match.
+ sub extract_exponent {
+ ($_[0] =~ s/([pP][+-]?\d+)//) && return $1;
+ }
+ my $re = extract_exponent($rh);
+ my $ee = extract_exponent($eh);
+ print "# re = $re, ee = $ee (rh $rh, eh $eh)\n";
+ if ($re eq $ee) { # If exponents match.
+ # Remove the common prefix of the mantissa bits.
+ my $la = length($rh);
+ my $lb = length($eh);
+ my $i;
+ for ($i = 0; $i < $la && $i < $lb; $i++) {
+ last if substr($rh, $i, 1) ne substr($eh, $i, 1);
+ }
+ $rh = substr($rh, $i);
+ $eh = substr($eh, $i);
+ print "# (rh $rh, eh $eh)\n";
+ if ($rh ne $eh) {
+ # If necessary, pad the shorter one on the right
+ # with one zero (for example "...1f" vs "...2",
+ # we want to compare "1f" to "20").
+ if (length $rh < length $eh) {
+ $rh .= '0';
+ } elsif (length $eh < length $rh) {
+ $eh .= '0';
+ }
+ print "# (rh $rh, eh $eh)\n";
+ if (length $eh == length $rh) {
+ if (abs(hex($eh) - hex($rh)) == 1) {
+ $ok = 1;
+ }
+ }
+ }
+ }
+ }
+ }
+ ok($ok, "'$format' '$arg' -> '$result' cf '$expected'");
}
BEGIN { require "./test.pl"; }
-plan( tests => 49 );
+plan( tests => 50 );
# Used to segfault (bug #15479)
fresh_perl_like(
sub foo{};
1
', 'no crashing or errors when clobbering the current package';
+
+# Bareword lookup should not vivify stashes
+is runperl(
+ prog =>
+ 'sub foo { print shift, qq-\n- } SUPER::foo bar if 0; foo SUPER',
+ stderr => 1,
+ ),
+ "SUPER\n",
+ 'bareword lookup does not vivify stashes';
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
-plan( tests => 34 );
+plan( tests => 37 );
sub empty_sub {}
use strict; use warnings; eval q/use File::{Spec}/; eval q/use File::Spec/;
EOS
"check special blocks are cleared on error");
+
+use constant { constant1 => 1, constant2 => 2 };
+{
+ my $w;
+ local $SIG{__WARN__} = sub { $w++ };
+ eval 'sub constant1; sub constant2($)';
+ is eval '&constant1', '1',
+ 'stub re-declaration of constant with no prototype';
+ is eval '&constant2', '2',
+ 'stub re-declaration of constant with wrong prototype';
+ is $w, 2, 'two warnings from the above';
+}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ require './test.pl';
+ set_up_inc('../lib');
}
use warnings ;
}
};
-BEGIN { require './test.pl'; }
-
plan(387);
run_tests() unless caller;
# simple removal
sub removed2 { 24 }
sub bound2 { removed2() }
-undef $main::{removed2};
+{ no strict; undef *{"removed2"} }
eval { bound2() };
like( $@, qr/Undefined subroutine &main::removed2 called/,
'function not bound' );
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
- skip_all_if_miniperl("no dynamic loading on miniperl, no re");
+ set_up_inc('../lib');
}
use strict;
use Config;
-plan tests => 800;
+plan tests => 801;
$| = 1;
}
SKIP: {
- skip "no Fcntl", 18 unless $has_fcntl;
+ skip "no Fcntl", 36 unless $has_fcntl;
my $foo = tempfile();
my $evil = $foo . $TAINT;
$_ = "$TAINT".reset "x";
is eval { eval $::x.1 }, 1, 'reset does not taint undef';
+# [perl #122669]
+{
+ # See the comment above the first formline test.
+ local $ENV{PATH} = $ENV{PATH};
+ $ENV{PATH} = $old_env_path if $Is_MSWin32;
+ is runperl(
+ switches => [ '-T' ],
+ prog => 'use constant K=>$^X; 0 if K; BEGIN{} use strict; '
+ .'print 122669, qq-\n-',
+ stderr => 1,
+ ), "122669\n",
+ 'tainted constant as logop condition should not prevent "use"';
+}
+
# This may bomb out with the alarm signal so keep it last
SKIP: {
skip "No alarm()" unless $Config{d_alarm};
untie %h;
EXPECT
########
+# SKIP !defined &DynaLoader::boot_DynaLoader && !eval 'require base'
+# (skip under miniperl if base.pm is not in lib/ yet)
# standard behaviour, without any extra references
use Tie::Hash ;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
plan (tests => 312);
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ require './test.pl';
+ set_up_inc(qw '../lib ../dist/base/lib');
}
my @expect;
my $data = "";
my @data = ();
-require './test.pl';
plan(tests => 67);
sub compare {
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 134;
use vars qw(@ary %ary %hash);
-plan 73;
+plan 74;
ok !defined($a);
}
is $_[0], $_[1], 'undef constants preserve identity';
+# [perl #122556]
+my $messages;
+package Thingie;
+DESTROY { $messages .= 'destroyed ' }
+package main;
+sub body {
+ sub {
+ my $t = bless [], 'Thingie';
+ undef $t;
+ }->(), $messages .= 'after ';
+
+ return;
+}
+body();
+is $messages, 'destroyed after ', 'undef $scalar frees refs immediately';
+
+
# this will segfault if it fails
sub PVBM () { 'foo' }
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ require './test.pl';
+ set_up_inc(qw '../lib ../dist/base/lib');
$| = 1;
require "./test.pl";
}
BEGIN {
chdir 't' if -d 't';
- @INC = qw(../lib);
+ require './test.pl';
+ set_up_inc('../lib');
}
use strict;
any_tainted @_;
}
-require './test.pl';
plan(tests => 3*10 + 3*8 + 2*16 + 3);
my $arg = $ENV{PATH}; # a tainted value
is(tainted($taint), tainted($arg), "tainted: $encode, downgrade down");
}
-{
+SKIP: {
+ if (is_miniperl()) {
+ skip_if_miniperl("Unicode tables not built yet", 2)
+ unless eval 'require "unicore/Heavy.pl"';
+ }
fresh_perl_is('$a = substr $^X, 0, 0; /\x{100}/i; /$a\x{100}/i || print q,ok,',
'ok', {switches => ["-T", "-l"]},
"matching a regexp is taint agnostic");
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
+ require './test.pl';
+ set_up_inc('../lib');
}
-require "test.pl";
plan( tests => 35 );
my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan 32;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use strict; # Amazed that this hackery can be made strict ...
use strict;
-plan 5;
+plan 9;
-my $err = "Unimplemented at $0 line " . ( __LINE__ + 2 ) . ".\n";
+my $err;
+my $err1 = "Unimplemented at $0 line ";
+my $err2 = ".\n";
+$err = $err1 . ( __LINE__ + 1 ) . $err2;
eval { ... };
+is $@, $err, "Execution of ellipsis statement reported 'Unimplemented' code";
+$@ = '';
-is $@, $err;
+note("RT #122661: Semicolon before ellipsis statement disambiguates to indicate block rather than hash reference");
+my @input = (3..5);
+my @transformed;
+$err = $err1 . ( __LINE__ + 1 ) . $err2;
+eval { @transformed = map {; ... } @input; };
+is $@, $err, "Disambiguation case 1";
+$@ = '';
+$err = $err1 . ( __LINE__ + 1 ) . $err2;
+eval { @transformed = map {;...} @input; };
+is $@, $err, "Disambiguation case 2";
+$@ = '';
+
+$err = $err1 . ( __LINE__ + 1 ) . $err2;
+eval { @transformed = map {; ...} @input; };
+is $@, $err, "Disambiguation case 3";
+$@ = '';
+
+$err = $err1 . ( __LINE__ + 1 ) . $err2;
+eval { @transformed = map {;... } @input; };
+is $@, $err, "Disambiguation case 4";
+$@ = '';
#
# Regression tests, making sure ... is still parsable as an operator.
# functions imported from t/test.pl or Test::More, as those programs/libraries
# use operators which are what is being tested in this file.
-print "1..175\n";
+print "1..181\n";
sub try ($$$) {
print +($_[1] ? "ok" : "not ok"), " $_[0] - $_[2]\n";
try $T++, 0.1530001e-305 != 0.0, '0.1530001e-305';
try $T++, 1.17549435100e-38 != 0.0, 'min single';
try $T++, 2.2250738585072014e-308 != 0.0, 'min double';
+
+# string-to-nv should equal float literals
+try $T++, "1.23" + 0 == 1.23, '1.23';
+try $T++, " 1.23" + 0 == 1.23, '1.23 with leading space';
+try $T++, "1.23 " + 0 == 1.23, '1.23 with trailing space';
+try $T++, "+1.23" + 0 == 1.23, '1.23 with unary plus';
+try $T++, "-1.23" + 0 == -1.23, '1.23 with unary minus';
+try $T++, "1.23e4" + 0 == 12300, '1.23e4';
require 't/test.pl';
-plan(tests => 9);
+plan(tests => 6);
use_ok('Module::CoreList');
use_ok('Module::CoreList::Utils');
ok( defined $Module::CoreList::version{ $] }, "$] exists in version" );
ok( defined $Module::CoreList::Utils::utilities{$] }, "$] exists in Utils" );
}
-
-#plan skip_all => 'Special case v5.21.1 because rjbs' if sprintf("v%vd", $^V) eq 'v5.21.1';
-
-my @modules = qw[
- Module::CoreList
- Module::CoreList::Utils
- Module::CoreList::TieHashDelta
-];
-
-SKIP: {
- skip('Special case v5.21.1 because rjbs', 3) if sprintf("v%vd", $^V) eq 'v5.21.1';
- foreach my $mod ( @modules ) {
- my $vers = eval $mod->VERSION;
- ok( !( $vers < $] || $vers > $] ), "$mod version should match perl version in core" )
- or diag("$mod $vers doesn't match $]");
- }
-}
DB_File cpan/DB_File/DB_File.xs 140cd1d47c6830d1cb51b2207fd7c7d5ce8fb924
Digest::MD5 cpan/Digest-MD5/t/files.t bdbe05b705d9da305fedce7a9f4b6ba63250c7cf
+Digest::SHA cpan/Digest-SHA/hints/hpux.pl 8cf51e816894ee03826eac737bd6843300d6e64c
+ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm f738b4b8d6dfdb2bae5f3e43106370867aa88f01
+ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/pm_to_blib.t 2cd28c8279d7900e28962712763eaa4768117414
PerlIO::via::QuotedPrint cpan/PerlIO-via-QuotedPrint/t/QuotedPrint.t ca39f0146e89de02c746e199c45dcb3e5edad691
Text::Balanced cpan/Text-Balanced/t/01_compile.t 1598cf491a48fa546260a2ec41142abe84da533d
Text::Balanced cpan/Text-Balanced/t/02_extbrk.t 6ba1b64a4604e822dc2260b8ffcea6b406339ee8
autodie cpan/autodie/t/utf8_open.t 5295851351c49f939008c5aca6a798742b1e503d
podlators cpan/podlators/scripts/pod2man.PL f81acf53f3ff46cdcc5ebdd661c5d13eb35d20d6
podlators cpan/podlators/scripts/pod2text.PL b4693fcfe4a0a1b38a215cfb8985a65d5d025d69
-version cpan/version/lib/version.pm fa9931d4db05aff9a0a6ef558610b1a472d9306e
+version cpan/version/lib/version.pm d0923b895d57f1d669ae36fcf85c87b16db341d1
version vutil.c 668f17ca43e2527645674d29ba772b86330d5663
-version vxs.inc 9064aacbdfe42bb584a068f62b505dd11dbb4dc4
push @functions, 'Perl_' . $_->[2] if $_->[0] =~ /p/;
push @functions, 'S_' . $_->[2] if $_->[0] =~ /s/;
};
+push @functions, 'Perl_mess';
my $regcomp_fail_re = '\b(?:(?:Simple_)?v)?FAIL[2-4]?(?:utf8f)?\b';
my $regcomp_re =
Can't get short module name from a handle
Can't load DLL `%s', possible problematic module `%s'
Can't locate %s: %s
-Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
Can't pipe "%s": %s
Can't set type on DOS
Can't spawn: %s
Operator or semicolon missing before %c%s
Out of memory during list extend
panic queryaddr
+Parse error
PerlApp::TextQuery: no arguments, please
POSIX syntax [%c %c] is reserved for future extensions in regex; marked by <-- HERE in m/%s/
ptr wrong %p != %p fl=%x nl=%p e=%p for %d
my @programs;
find(
- { no_chidr => 1, wanted => sub {
+ { no_chdir => 1, wanted => sub {
my $name = $File::Find::name;
return if $name =~ /blib/;
return unless $name =~ m{/(?:bin|scripts?)/\S+\z} && $name !~ m{/t/};
-# This file is the data file for porting/podcheck.t.
+# This file is the data file for porting\podcheck.t.
# There are three types of lines.
# Comment lines are white-space only or begin with a '#', like this one. Any
# changes you make to the comment lines will be lost when the file is
ext/dynaloader/dynaloader.pm Verbatim line length including indents exceeds 79 by 1
ext/file-find/lib/file/find.pm Verbatim line length including indents exceeds 79 by 1
ext/file-glob/glob.pm Verbatim line length including indents exceeds 79 by 15
+ext/hash-util-fieldhash/lib/hash/util/fieldhash.pm Apparent broken link 1
ext/hash-util/lib/hash/util.pm Verbatim line length including indents exceeds 79 by 2
ext/pod-html/testdir/perlpodspec-copy.pod Verbatim line length including indents exceeds 79 by 8
ext/pod-html/testdir/perlvar-copy.pod ? Should you be using L<...> instead of 3
pod/perldebguts.pod Verbatim line length including indents exceeds 79 by 34
pod/perldebtut.pod Verbatim line length including indents exceeds 79 by 22
pod/perldebug.pod Verbatim line length including indents exceeds 79 by 3
+pod/perldelta.pod Apparent broken link 1
pod/perldsc.pod Verbatim line length including indents exceeds 79 by 4
pod/perldtrace.pod Verbatim line length including indents exceeds 79 by 26
pod/perlfunc.pod ? Should you be using F<...> or maybe L<...> instead of 1
$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+)?$/) {
+ } elsif (/^\(__DATA,__\w*?(const|data|bss|common)\w*\) (?:non-)?external _(\w+)(\.\w+)?$/) {
my ($dtype, $symbol, $suffix) = ($1, $2, $3);
# Ignore function-local constants like
# _Perl_pp_gmtime.dayname
# There are certain symbols we expect to see.
-# memchr, memcmp, memcpy should be used all over the place.
-#
-# chmod, socket, getenv, sigaction, sqrt, time are system/library
-# calls that should each see at least one use. sqrt can be sqrtl
+# chmod, socket, getenv, sigaction, exp, time are system/library
+# calls that should each see at least one use. exp can be expl
# if so configured.
my %expected = (
- memchr => 'd_memchr',
- memcmp => 'd_memcmp',
- memcpy => 'd_memcpy',
chmod => undef, # There is no Configure symbol for chmod.
socket => 'd_socket',
getenv => undef, # There is no Configure symbol for getenv,
time => 'd_time',
);
-if ($Config{uselongdouble} && $Config{d_longdbl}) {
- $expected{sqrtl} = 'd_sqrtl';
+if ($Config{uselongdouble} && $Config{longdblsize} > $Config{doublesize}) {
+ if ($Config{usequadmath}) {
+ $expected{expq} = undef; # There is no Configure symbol for expq.
+ } else {
+ $expected{expl} = undef; # There is no Configure symbol for expl.
+ }
} else {
- $expected{sqrt} = undef; # There is no Configure symbol for sqrt.
+ $expected{exp} = undef; # There is no Configure symbol for exp.
}
# DynaLoader will use dlopen, unless we are building static,
-# and in the platforms we are supporting in this test.
+# and it is used in the platforms we are supporting in this test.
if ($Config{usedl} ) {
$expected{dlopen} = 'd_dlopen';
}
}
my @o = exists $symbols{undef}{$symbol} ?
sort keys %{ $symbols{undef}{$symbol} } : ();
- # In some FreeBSD versions memcmp disappears (compiler inlining?).
- if (($^O eq 'freebsd' ||
- (defined $fake_style && $fake_style eq 'freebsd')) &&
- $symbol eq 'memcmp' && @o == 0) {
- SKIP: {
- skip("freebsd memcmp");
- }
- } else {
- ok(@o, "uses $symbol (@o)");
- }
+ ok(@o, "uses $symbol (@o)");
}
# There are certain symbols we expect NOT to see.
use warnings;
require 't/test.pl';
-open(my $fh, '<', 'Porting/README.pod') or die("Can't open Porting/README.pod: $!");
-
-my @porting_files = grep { !/~\z/ } glob("Porting/*");
+my @porting_files;
+open my $man, "MANIFEST" or die "Can't open MANIFEST: $!";
+while(<$man>) {
+ /^Porting\// and s/[\t\n].*//s, push @porting_files, $_;
+}
+close $man or die "Can't close MANIFEST: $!";
# It seems that dying here is nicer than having several dozen failing tests
# later. But that assumes one will see the message from die.
die "Can't get contents of Porting/ directory.\n" unless @porting_files > 1;
+open(my $fh, '<', 'Porting/README.pod') or die("Can't open Porting/README.pod: $!");
+
my (@current_order, @sorted_order, %files_in_pod);
while(<$fh>) {
next unless $_ =~ /^=head/;
for my $file (@porting_files) {
$file =~ s!^Porting/!!;
- $file =~ s/\.\z// if $^O eq 'VMS';
next if $file =~ /^perl[0-9]+delta\.pod$/;
ok(exists($files_in_pod{$file}), "$file is mentioned in Porting/README.pod");
delete $files_in_pod{$file};
skip_all( "Not all files are available during cross-compilation" );
}
-my $tests = 25; # I can't see a clean way to calculate this automatically.
+my $tests = 26; # I can't see a clean way to calculate this automatically.
my %skip = ("regen_perly.pl" => [qw(perly.act perly.h perly.tab)],
"regen/keywords.pl" => [qw(keywords.c keywords.h)],
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ @INC = qw '../lib ../dist/if';
require './test.pl';
require './loc_tools.pl';
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ @INC = qw '../lib ../ext/re';
require './test.pl';
}
BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib','.');
+ @INC = ('../lib','.','../ext/re');
require Config; import Config;
require './test.pl';
+ skip_all_without_unicode_tables();
}
-plan tests => 737; # Update this when adding/deleting tests.
+plan tests => 739; # Update this when adding/deleting tests.
run_tests() unless caller;
ok('a<b>c' =~ qr<a\<b\>c>, "'\\<' is a literal in qr<...>)");
}
+ { # Was getting optimized into EXACT (non-folding node)
+ my $x = qr/[x]/i;
+ utf8::upgrade($x);
+ like("X", qr/$x/, "UTF-8 of /[x]/i matches upper case");
+ }
+
+ { # make sure we get an error when \p{} cannot load Unicode tables
+ fresh_perl_like(<<' prog that cannot load uni tables',
+ BEGIN {
+ @INC = '../lib';
+ require utf8; require 'utf8_heavy.pl';
+ @INC = ();
+ }
+ $name = 'A B';
+ if ($name =~ /(\p{IsUpper}) (\p{IsUpper})/){
+ print "It's good! >$1< >$2<\n";
+ } else {
+ print "It's not good...\n";
+ }
+ prog that cannot load uni tables
+ qr/^Can't locate unicore\/Heavy\.pl(?x:
+ )|^Can't find Unicode property definition/,
+ undef,
+ '\p{} should not fail silently when uni tables evanesce');
+ }
} # End of sub run_tests
1;
#
my $w;
local $SIG {__WARN__} = sub {$w .= "@_"};
- eval 'q(xxWxx) =~ /[\N{WARN}]/';
- ok $w && $w =~ /Using just the first character returned by \\N\{} in character class/,
- "single character in [\\N{}] warning";
+ $result = eval 'q(WARN) =~ /[\N{WARN}]/';
+ ok !$@ && $result && ! $w, '\N{} returning multi-char works';
undef $w;
eval q [ok "\0" !~ /[\N{EMPTY-STR}XY]/,
BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib','.');
require './test.pl';
+ set_up_inc('../lib');
}
BEGIN {
chdir 't';
- @INC = qw(lib ../lib);
require './test.pl';
+ set_up_inc(qw(lib ../lib));
}
plan 48;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ @INC = qw '../lib ../ext/re';
require './test.pl';
+ skip_all_without_unicode_tables();
eval 'require Config'; # assume defaults if this fails
}
'm/(?[[\w-x]])/' => 'False [] range "\w-" {#} m/(?[[\w-{#}x]])/',
'm/(?[[a-\pM]])/' => 'False [] range "a-\pM" {#} m/(?[[a-\pM{#}]])/',
'm/(?[[\pM-x]])/' => 'False [] range "\pM-" {#} m/(?[[\pM-{#}x]])/',
- 'm/(?[[\N{LATIN CAPITAL LETTER A WITH MACRON AND GRAVE}]])/' => '\N{} in character class restricted to one character {#} m/(?[[\N{U+100.300{#}}]])/',
+ 'm/(?[[^\N{LATIN CAPITAL LETTER A WITH MACRON AND GRAVE}]])/' => '\N{} in inverted character class or as a range end-point is restricted to one character {#} m/(?[[^\N{U+100.300{#}}]])/',
'm/(?[ \p{Digit} & (?(?[ \p{Thai} | \p{Lao} ]))])/' => 'Sequence (?(...) not recognized {#} m/(?[ \p{Digit} & (?({#}?[ \p{Thai} | \p{Lao} ]))])/',
'm/(?[ \p{Digit} & (?:(?[ \p{Thai} | \p{Lao} ]))])/' => 'Expecting \'(?flags:(?[...\' {#} m/(?[ \p{Digit} & (?{#}:(?[ \p{Thai} | \p{Lao} ]))])/',
'm/\o{/' => 'Missing right brace on \o{ {#} m/\o{{#}/',
# In the following arrays of warnings, the value can be an array of things to
# expect. If the empty string, it means no warning should be raised.
-##
-## Key-value pairs of code/error of code that should have non-fatal regexp warnings.
-##
-my @warning = (
- 'm/\b*/' => '\b* matches null string many times {#} m/\b*{#}/',
- 'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes {#} m/[:blank:]{#}/',
- "m'[\\y]'" => 'Unrecognized escape \y in character class passed through {#} m/[\y{#}]/',
+# Key-value pairs of code/error of code that should have non-fatal regexp
+# warnings. Most currently have \x{100} appended to them to force them to be
+# upgraded to UTF-8, and the first pass restarted. Previously this would
+# cause some warnings to be output twice. This tests that that behavior has
+# been fixed.
- 'm/[a-\d]/' => 'False [] range "a-\d" {#} m/[a-\d{#}]/',
- 'm/[\w-x]/' => 'False [] range "\w-" {#} m/[\w-{#}x]/',
- 'm/[a-\pM]/' => 'False [] range "a-\pM" {#} m/[a-\pM{#}]/',
- 'm/[\pM-x]/' => 'False [] range "\pM-" {#} m/[\pM-{#}x]/',
- "m'\\y'" => 'Unrecognized escape \y passed through {#} m/\y{#}/',
+my @warning = (
+ 'm/\b*\x{100}/' => '\b* matches null string many times {#} m/\b*{#}\x{100}/',
+ 'm/[:blank:]\x{100}/' => 'POSIX syntax [: :] belongs inside character classes {#} m/[:blank:]{#}\x{100}/',
+ "m'[\\y]\\x{100}'" => 'Unrecognized escape \y in character class passed through {#} m/[\y{#}]\x{100}/',
+ 'm/[a-\d]\x{100}/' => 'False [] range "a-\d" {#} m/[a-\d{#}]\x{100}/',
+ 'm/[\w-x]\x{100}/' => 'False [] range "\w-" {#} m/[\w-{#}x]\x{100}/',
+ 'm/[a-\pM]\x{100}/' => 'False [] range "a-\pM" {#} m/[a-\pM{#}]\x{100}/',
+ 'm/[\pM-x]\x{100}/' => 'False [] range "\pM-" {#} m/[\pM-{#}x]\x{100}/',
+ 'm/[^\N{LATIN CAPITAL LETTER A WITH MACRON AND GRAVE}]/' => 'Using just the first character returned by \N{} in character class {#} m/[^\N{U+100.300}{#}]/',
+ 'm/[\x03-\N{LATIN CAPITAL LETTER A WITH MACRON AND GRAVE}]/' => 'Using just the first character returned by \N{} in character class {#} m/[\x03-\N{U+100.300}{#}]/',
+ 'm/[\N{LATIN CAPITAL LETTER A WITH MACRON AND GRAVE}-\x{10FFFF}]/' => 'Using just the first character returned by \N{} in character class {#} m/[\N{U+100.300}{#}-\x{10FFFF}]/',
+ "m'\\y\\x{100}'" => 'Unrecognized escape \y passed through {#} m/\y{#}\x{100}/',
'/x{3,1}/' => 'Quantifier {n,m} with n > m can\'t match {#} m/x{3,1}{#}/',
'/\08/' => '\'\08\' resolved to \'\o{0}8\' {#} m/\08{#}/',
'/\018/' => '\'\018\' resolved to \'\o{1}8\' {#} m/\018{#}/',
'/(?=a)*/' => '(?=a)* matches null string many times {#} m/(?=a)*{#}/',
'my $x = \'\m\'; qr/a$x/' => 'Unrecognized escape \m passed through {#} m/a\m{#}/',
'/\q/' => 'Unrecognized escape \q passed through {#} m/\q{#}/',
- '/(?=a){1,3}/' => 'Quantifier unexpected on zero-length expression {#} m/(?=a){1,3}{#}/',
- '/(a|b)(?=a){3}/' => 'Quantifier unexpected on zero-length expression {#} m/(a|b)(?=a){3}{#}/',
+
+ # Feel free to modify these 2 tests, should they start failing because the
+ # marker of where the problem is becomes wrong. The current behavior is
+ # bad, always marking at the very end of the regex instead of where the
+ # problem is. See [perl #122680] regcomp warning gives wrong position of
+ # problem.
+ '/(?=a){1,3}\x{100}/' => 'Quantifier unexpected on zero-length expression {#} m/(?=a){1,3}\x{100}{#}/',
+ '/(a|b)(?=a){3}\x{100}/' => 'Quantifier unexpected on zero-length expression {#} m/(a|b)(?=a){3}\x{100}{#}/',
+
'/\_/' => "",
'/[\_\0]/' => "",
'/[\07]/' => "",
'/[\006]/' => "",
'/[\0005]/' => "",
- '/[\8\9]/' => ['Unrecognized escape \8 in character class passed through {#} m/[\8{#}\9]/',
- 'Unrecognized escape \9 in character class passed through {#} m/[\8\9{#}]/',
+ '/[\8\9]\x{100}/' => ['Unrecognized escape \8 in character class passed through {#} m/[\8{#}\9]\x{100}/',
+ 'Unrecognized escape \9 in character class passed through {#} m/[\8\9{#}]\x{100}/',
],
- '/[:alpha:]/' => 'POSIX syntax [: :] belongs inside character classes {#} m/[:alpha:]{#}/',
- '/[:zog:]/' => 'POSIX syntax [: :] belongs inside character classes {#} m/[:zog:]{#}/',
- '/[.zog.]/' => 'POSIX syntax [. .] belongs inside character classes {#} m/[.zog.]{#}/',
+ '/[:alpha:]\x{100}/' => 'POSIX syntax [: :] belongs inside character classes {#} m/[:alpha:]{#}\x{100}/',
+ '/[:zog:]\x{100}/' => 'POSIX syntax [: :] belongs inside character classes {#} m/[:zog:]{#}\x{100}/',
+ '/[.zog.]\x{100}/' => 'POSIX syntax [. .] belongs inside character classes {#} m/[.zog.]{#}\x{100}/',
'/[a-b]/' => "",
- '/[a-\d]/' => 'False [] range "a-\d" {#} m/[a-\d{#}]/',
- '/[\d-b]/' => 'False [] range "\d-" {#} m/[\d-{#}b]/',
- '/[\s-\d]/' => 'False [] range "\s-" {#} m/[\s-{#}\d]/',
- '/[\d-\s]/' => 'False [] range "\d-" {#} m/[\d-{#}\s]/',
- '/[a-[:digit:]]/' => 'False [] range "a-[:digit:]" {#} m/[a-[:digit:]{#}]/',
- '/[[:digit:]-b]/' => 'False [] range "[:digit:]-" {#} m/[[:digit:]-{#}b]/',
- '/[[:alpha:]-[:digit:]]/' => 'False [] range "[:alpha:]-" {#} m/[[:alpha:]-{#}[:digit:]]/',
- '/[[:digit:]-[:alpha:]]/' => 'False [] range "[:digit:]-" {#} m/[[:digit:]-{#}[:alpha:]]/',
- '/[a\zb]/' => 'Unrecognized escape \z in character class passed through {#} m/[a\z{#}b]/',
- '/(?c)/' => 'Useless (?c) - use /gc modifier {#} m/(?c{#})/',
- '/(?-c)/' => 'Useless (?-c) - don\'t use /gc modifier {#} m/(?-c{#})/',
- '/(?g)/' => 'Useless (?g) - use /g modifier {#} m/(?g{#})/',
- '/(?-g)/' => 'Useless (?-g) - don\'t use /g modifier {#} m/(?-g{#})/',
- '/(?o)/' => 'Useless (?o) - use /o modifier {#} m/(?o{#})/',
- '/(?-o)/' => 'Useless (?-o) - don\'t use /o modifier {#} m/(?-o{#})/',
- '/(?g-o)/' => [ 'Useless (?g) - use /g modifier {#} m/(?g{#}-o)/',
- 'Useless (?-o) - don\'t use /o modifier {#} m/(?g-o{#})/',
+ '/[a-\d]\x{100}/' => 'False [] range "a-\d" {#} m/[a-\d{#}]\x{100}/',
+ '/[\d-b]\x{100}/' => 'False [] range "\d-" {#} m/[\d-{#}b]\x{100}/',
+ '/[\s-\d]\x{100}/' => 'False [] range "\s-" {#} m/[\s-{#}\d]\x{100}/',
+ '/[\d-\s]\x{100}/' => 'False [] range "\d-" {#} m/[\d-{#}\s]\x{100}/',
+ '/[a-[:digit:]]\x{100}/' => 'False [] range "a-[:digit:]" {#} m/[a-[:digit:]{#}]\x{100}/',
+ '/[[:digit:]-b]\x{100}/' => 'False [] range "[:digit:]-" {#} m/[[:digit:]-{#}b]\x{100}/',
+ '/[[:alpha:]-[:digit:]]\x{100}/' => 'False [] range "[:alpha:]-" {#} m/[[:alpha:]-{#}[:digit:]]\x{100}/',
+ '/[[:digit:]-[:alpha:]]\x{100}/' => 'False [] range "[:digit:]-" {#} m/[[:digit:]-{#}[:alpha:]]\x{100}/',
+ '/[a\zb]\x{100}/' => 'Unrecognized escape \z in character class passed through {#} m/[a\z{#}b]\x{100}/',
+ '/(?c)\x{100}/' => 'Useless (?c) - use /gc modifier {#} m/(?c{#})\x{100}/',
+ '/(?-c)\x{100}/' => 'Useless (?-c) - don\'t use /gc modifier {#} m/(?-c{#})\x{100}/',
+ '/(?g)\x{100}/' => 'Useless (?g) - use /g modifier {#} m/(?g{#})\x{100}/',
+ '/(?-g)\x{100}/' => 'Useless (?-g) - don\'t use /g modifier {#} m/(?-g{#})\x{100}/',
+ '/(?o)\x{100}/' => 'Useless (?o) - use /o modifier {#} m/(?o{#})\x{100}/',
+ '/(?-o)\x{100}/' => 'Useless (?-o) - don\'t use /o modifier {#} m/(?-o{#})\x{100}/',
+ '/(?g-o)\x{100}/' => [ 'Useless (?g) - use /g modifier {#} m/(?g{#}-o)\x{100}/',
+ 'Useless (?-o) - don\'t use /o modifier {#} m/(?g-o{#})\x{100}/',
],
- '/(?g-c)/' => [ 'Useless (?g) - use /g modifier {#} m/(?g{#}-c)/',
- 'Useless (?-c) - don\'t use /gc modifier {#} m/(?g-c{#})/',
+ '/(?g-c)\x{100}/' => [ 'Useless (?g) - use /g modifier {#} m/(?g{#}-c)\x{100}/',
+ 'Useless (?-c) - don\'t use /gc modifier {#} m/(?g-c{#})\x{100}/',
],
# (?c) means (?g) error won't be thrown
- '/(?o-cg)/' => [ 'Useless (?o) - use /o modifier {#} m/(?o{#}-cg)/',
- 'Useless (?-c) - don\'t use /gc modifier {#} m/(?o-c{#}g)/',
+ '/(?o-cg)\x{100}/' => [ 'Useless (?o) - use /o modifier {#} m/(?o{#}-cg)\x{100}/',
+ 'Useless (?-c) - don\'t use /gc modifier {#} m/(?o-c{#}g)\x{100}/',
],
- '/(?ogc)/' => [ 'Useless (?o) - use /o modifier {#} m/(?o{#}gc)/',
- 'Useless (?g) - use /g modifier {#} m/(?og{#}c)/',
- 'Useless (?c) - use /gc modifier {#} m/(?ogc{#})/',
+ '/(?ogc)\x{100}/' => [ 'Useless (?o) - use /o modifier {#} m/(?o{#}gc)\x{100}/',
+ 'Useless (?g) - use /g modifier {#} m/(?og{#}c)\x{100}/',
+ 'Useless (?c) - use /gc modifier {#} m/(?ogc{#})\x{100}/',
],
- '/a{1,1}?/' => 'Useless use of greediness modifier \'?\' {#} m/a{1,1}?{#}/',
- '/b{3} +/x' => 'Useless use of greediness modifier \'+\' {#} m/b{3} +{#}/',
-);
+ '/a{1,1}?\x{100}/' => 'Useless use of greediness modifier \'?\' {#} m/a{1,1}?{#}\x{100}/',
+ '/b{3} +\x{100}/x' => 'Useless use of greediness modifier \'+\' {#} m/b{3} +{#}\x{100}/',
+); # See comments before this for why '\x{100}' is generally needed
my @warnings_utf8 = mark_as_utf8(
'm/ネ\b*ネ/' => '\b* matches null string many times {#} m/ネ\b*{#}ネ/',
BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib','.');
+ @INC = ('../lib','.','../ext/re');
require './test.pl';
+ skip_all_without_unicode_tables();
}
use utf8;
}
chdir 't' if -d 't';
- @INC = '../lib';
-
+ @INC = qw '../lib ../ext/re';
+ if (!defined &DynaLoader::boot_DynaLoader) { # miniperl
+ print("1..0 # Skip Unicode tables not built yet\n"), exit
+ unless eval 'require "unicore/Heavy.pl"';
+ }
}
sub _comment {
--- /dev/null
+#!./perl
+use strict;
+use warnings;
+
+$| = 1;
+
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = ('../lib','.','../ext/re');
+ require './test.pl';
+}
+
+plan tests => 3;
+use strict;
+
+my(@body) = (
+ "<mailto:xxxx.xxxx\@outlook.com>",
+ "A\x{B9}ker\x{E8}eva xxxx.xxxx\@outlook.com \x{201D}",
+);
+
+for (@body) {
+ s{ <? (?<!mailto:) \b ( [a-z0-9.]+ \@ \S+ ) \b
+ (?: > | \s{1,10} (?!phone) [a-z]{2,11} : ) }{ }xgi;
+ my $got= $1;
+ is( $got, '.xxxx@outlook.com' );
+}
+ok("got to the end without dieing (note without DEBUGGING passing this test means nothing)");
+
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 40;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
require './test.pl';
+ set_up_inc('../lib');
+ require Config; import Config;
require './charset_tools.pl';
}
# directory.
# It is skipped by default under PERL_DEBUG_READONLY_COW, but you can run
-# it directly via: cd t; ./perl ../lib/unicore/TestProp.pl
+# it directly via: cd t; ./perl -I../lib ../lib/unicore/TestProp.pl
require Config;
if ($Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DEBUG_READONLY_COW\b/) {
do '../lib/unicore/TestProp.pl';
+# Since TestProp.pl explicitly exits, we will only get here if it
+# could not load.
+if (defined &DynaLoader::boot_DynaLoader # not miniperl
+ || eval 'require "unicore/Heavy.pl"' # or tables are built
+) {
+ die "Could not run lib/unicore/TestProp.pl: ", $@||$!;
+}
+else {
+ print "1..0 # Skip Unicode tables not built yet\n";
+}
+
0
/^([[:digit:]]+)/;
EXPECT
######## [perl #20667] unicode regex vs non-unicode regex
+# SKIP: !defined &DynaLoader::boot_DynaLoader && !eval 'require "unicore/Heavy.pl"'
+# (skip under miniperl if Unicode tables are not built yet)
$toto = 'Hello';
$toto =~ /\w/; # this line provokes the problem!
$name = 'A B';
try({PERL5OPT => '-Mstrict'}, ['-I../lib', '-e', 'print $x'],
"",
- qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
+ qq{Global symbol "\$x" requires explicit package name (did you forget to declare "my \$x"?) at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
# Fails in 5.6.0
try({PERL5OPT => '-Mstrict -w'}, ['-I../lib', '-e', 'print $x'],
"",
- qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
+ qq{Global symbol "\$x" requires explicit package name (did you forget to declare "my \$x"?) at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
# Fails in 5.6.0
try({PERL5OPT => '-w -Mstrict'}, ['-I../lib', '-e', 'print $::x'],
plan(4);
like(runperl(switches => ['-Irun/flib', '-Mbroken'], stderr => 1),
- qr/^Global symbol "\$x" requires explicit package name at run\/flib\/broken.pm line 6\./,
+ qr/^Global symbol "\$x" requires explicit package name \(did you (?x:
+ )forget to declare "my \$x"\?\) at run\/flib\/broken.pm line 6\./,
"Ensure -Irun/flib produces correct filename in warnings");
like(runperl(switches => ['-Irun/flib/', '-Mbroken'], stderr => 1),
- qr/^Global symbol "\$x" requires explicit package name at run\/flib\/broken.pm line 6\./,
+ qr/^Global symbol "\$x" requires explicit package name \(did you (?x:
+ )forget to declare "my \$x"\?\) at run\/flib\/broken.pm line 6\./,
"Ensure -Irun/flib/ produces correct filename in warnings");
SKIP: {
plan(tests => 115);
use Config;
-use Errno qw(EACCES EISDIR);
BEGIN { eval 'use POSIX qw(setlocale LC_ALL)' }
# due to a bug in VMS's piping which makes it impossible for runperl()
# Win32 won't let us open the directory, so we never get to die with
# EISDIR, which happens after open.
- my $error = do { local $! = $^O eq 'MSWin32' ? EACCES : EISDIR; "$!" };
+ require Errno;
+ import Errno qw(EACCES EISDIR);
+ my $error = do {
+ local $! = $^O eq 'MSWin32' ? &EACCES : &EISDIR; "$!"
+ };
like(
runperl( switches => [ '-c' ], args => [ $tempdir ], stderr => 1),
qr/Can't open perl script.*$tempdir.*\Q$error/s,
return !defined &DynaLoader::boot_DynaLoader;
}
+sub set_up_inc {
+ # Don’t clobber @INC under miniperl
+ @INC = () unless is_miniperl;
+ unshift @INC, @_;
+}
+
sub _comment {
return map { /^#/ ? "$_\n" : "# $_\n" }
map { split /\n/ } @_;
}
}
+sub skip_all_without_unicode_tables { # (but only under miniperl)
+ if (is_miniperl()) {
+ skip_all_if_miniperl("Unicode tables not built yet")
+ unless eval 'require "unicore/Heavy.pl"';
+ }
+}
+
sub find_git_or_skip {
my ($source_dir, $reason);
if (-d '.git') {
BEGIN {
chdir 't' if -d 't';
- @INC = qw(../lib .);
- require "test.pl";
+ require './test.pl';
+ set_up_inc('../lib');
+ skip_all_without_unicode_tables();
}
plan tests => 1;
-require "test.pl";
+BEGIN {
+ require "test.pl";
+ set_up_inc(qw(../lib .));
+ skip_all_without_unicode_tables();
+}
use strict;
use warnings;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(../lib .);
- require "test.pl";
+ require './test.pl';
+ set_up_inc(qw(../lib .));
+ skip_all_without_unicode_tables();
}
plan tests => 11;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
require './test.pl';
+ set_up_inc('../lib');
+ skip_all_without_unicode_tables();
+ require Config; import Config;
require './loc_tools.pl'; # Contains find_utf8_ctype_locale()
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
+ skip_all_without_unicode_tables();
}
use utf8;
use open qw( :utf8 :std );
use warnings;
-plan( tests => 207 );
+plan( tests => 206 );
# type coersion on assignment
$ᕘ = 'ᕘ';
format =
.
- foreach my $value ({1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) {
+ foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) {
# *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns
# IO::Handle, which isn't what we want.
my $type = $value;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
+ skip_all_without_unicode_tables();
}
use utf8;
chdir 't';
@INC = '../lib';
require './test.pl';
- skip_all_if_miniperl("no dynamic loading on miniperl, no re");
+ skip_all_without_unicode_tables();
skip_all('EBCDIC') if $::IS_EBCDIC;
}
use strict;
-plan (tests => 15);
+plan (tests => 16);
use charnames ':full';
use utf8;
is $@, "", 'y/// compiles, where / is actually a wide character';
is $_, "b", 'transliteration worked';
+use constant foofoo=>qq|\xc4\xb5|;
+{ no strict; ()=${"\xc4\xb5::foo"} } # vivify ĵ package
+eval 'my foofoo $dog'; # foofoo was resolving to ĵ, not ĵ
+is $@, '', 'my constant $var in utf8 scope where constant is not utf8';
+
__END__
BEGIN {
chdir 't' if -d 't';
- @INC = qw(../lib uni .);
- require "case.pl";
+ require "uni/case.pl";
}
casetest(0, # No extra tests run here,
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
+ @INC = qw(. ../lib ../cpan/parent/lib);
require "test.pl";
}
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ @INC = qw '../lib ../dist/base/lib';
require './test.pl';
}
}
END_FIELDS
+die $@ if $@;
+
for (
[ element => 'my ＦŌŌ $bàr = ＦŌŌ->new; $bàr->{クラス};' ],
[ slice => 'my ＦŌŌ $bàr = ＦŌŌ->new; @{$bàr}{ qw( a クラス ) };' ]
BEGIN {
require './test.pl';
+ skip_all_without_unicode_tables();
}
-plan (tests => 52);
+plan (tests => 51);
use utf8;
use open qw( :utf8 :std );
-ok *tèst, "*main::tèst", "sanity check.";
+is *tèst, "*main::tèst", "sanity check.";
ok $::{"tèst"}, "gets the right glob in the stash.";
my $glob_by_sub = sub { *ｍａｉｎ::method }->();
sub участники { 1 }
ok $::{"участники"}, "non-const sub declarations generate the right glob";
-ok *{$::{"участники"}}{CODE};
-is *{$::{"участники"}}{CODE}->(), 1;
+is $::{"участники"}->(), 1;
sub 原 () { 1 }
BEGIN {
chdir 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
plan tests => 7;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
require './test.pl';
+ set_up_inc('../lib');
}
use utf8;
BEGIN {
chdir 't' if -d 't';
- @INC = qw(../lib uni .);
- require "case.pl";
+ require "uni/case.pl";
}
casetest(0, # No extra tests run here,
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ @INC = qw '../lib ../dist/base/lib';
$| = 1;
require "./test.pl";
}
BEGIN {
chdir 't' if -d 't';
- @INC = qw(../lib uni .);
- require "case.pl";
+ require "uni/case.pl";
}
is(uc("\x{3B1}\x{345}\x{301}"), "\x{391}\x{301}\x{399}", 'Verify moves YPOGEGRAMMENI');
BEGIN {
require './test.pl';
+ skip_all_without_unicode_tables();
}
use 5.016;
try({PERL5OPT => '-Mstrict'}, ['-I..\lib', '-e', '"print $x"'],
"",
- qq(Global symbol "\$x" requires explicit package name at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL}));
+ qq(Global symbol "\$x" requires explicit package name (did you forget to declare "my \$x"?) at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL}));
# Fails in 5.6.0
try({PERL5OPT => '-Mstrict -w'}, ['-I..\lib', '-e', '"print $x"'],
"",
- qq(Global symbol "\$x" requires explicit package name at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL}));
+ qq(Global symbol "\$x" requires explicit package name (did you forget to declare "my \$x"?) at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL}));
# Fails in 5.6.0
try({PERL5OPT => '-w -Mstrict'}, ['-I..\lib', '-e', '"print $::x"'],
#define CHEAT_YEARS 108
#define IS_LEAP(n) ((!(((n) + 1900) % 400) || (!(((n) + 1900) % 4) && (((n) + 1900) % 100))) != 0)
+#undef WRAP /* some <termios.h> define this */
#define WRAP(a,b,m) ((a) = ((a) < 0 ) ? ((b)--, (a) + (m)) : (a))
#ifdef USE_SYSTEM_LOCALTIME
p->tm_zone = (char *)"UTC";
#endif
- v_tm_sec = (int)fmod(time, 60.0);
- time = time >= 0 ? floor(time / 60.0) : ceil(time / 60.0);
- v_tm_min = (int)fmod(time, 60.0);
- time = time >= 0 ? floor(time / 60.0) : ceil(time / 60.0);
- v_tm_hour = (int)fmod(time, 24.0);
- time = time >= 0 ? floor(time / 24.0) : ceil(time / 24.0);
+ v_tm_sec = (int)Perl_fmod(time, 60.0);
+ time = time >= 0 ? Perl_floor(time / 60.0) : Perl_ceil(time / 60.0);
+ v_tm_min = (int)Perl_fmod(time, 60.0);
+ time = time >= 0 ? Perl_floor(time / 60.0) : Perl_ceil(time / 60.0);
+ v_tm_hour = (int)Perl_fmod(time, 24.0);
+ time = time >= 0 ? Perl_floor(time / 24.0) : Perl_ceil(time / 24.0);
v_tm_tday = time;
WRAP (v_tm_sec, v_tm_min, 60);
WRAP (v_tm_min, v_tm_hour, 60);
WRAP (v_tm_hour, v_tm_tday, 24);
- v_tm_wday = (int)fmod((v_tm_tday + 4.0), 7.0);
+ v_tm_wday = (int)Perl_fmod((v_tm_tday + 4.0), 7.0);
if (v_tm_wday < 0)
v_tm_wday += 7;
m = v_tm_tday;
if (m >= 0) {
/* Gregorian cycles, this is huge optimization for distant times */
- cycles = (int)floor(m / (Time64_T) days_in_gregorian_cycle);
+ cycles = (int)Perl_floor(m / (Time64_T) days_in_gregorian_cycle);
if( cycles ) {
m -= (cycles * (Time64_T) days_in_gregorian_cycle);
year += (cycles * years_in_gregorian_cycle);
year--;
/* Gregorian cycles */
- cycles = (int)ceil((m / (Time64_T) days_in_gregorian_cycle) + 1);
+ cycles = (int)Perl_ceil((m / (Time64_T) days_in_gregorian_cycle) + 1);
if( cycles ) {
m -= (cycles * (Time64_T) days_in_gregorian_cycle);
year += (cycles * years_in_gregorian_cycle);
#define PL_lex_casestack (PL_parser->lex_casestack)
#define PL_lex_defer (PL_parser->lex_defer)
#define PL_lex_dojoin (PL_parser->lex_dojoin)
-#define PL_lex_expect (PL_parser->lex_expect)
#define PL_lex_formbrack (PL_parser->lex_formbrack)
#define PL_lex_inpat (PL_parser->lex_inpat)
#define PL_lex_inwhat (PL_parser->lex_inwhat)
#define SPACE_OR_TAB(c) isBLANK_A(c)
+#define HEXFP_PEEK(s) \
+ (((s[0] == '.') && \
+ (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
+ isALPHA_FOLD_EQ(s[0], 'p'))
+
/* LEX_* are values for PL_lex_state, the state of the lexer.
* They are arranged oddly so that the guard on the switch statement
* can get by with a single comparison (if the compiler is smart enough).
#define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
-# define SKIPSPACE0(s) skipspace(s)
-# define SKIPSPACE1(s) skipspace(s)
-# define SKIPSPACE2(s,tsv) skipspace(s)
-# define PEEKSPACE(s) skipspace(s)
-
/*
* Convenience functions to return different tokens and prime the
* lexer for the next token. They all take an argument.
* PWop : power operator
* PMop : pattern-matching operator
* Aop : addition-level operator
+ * AopNOASSIGN : addition-level operator that is never part of .=
* Mop : multiplication-level operator
* Eop : equality-testing operator
* Rop : relational operator <= != gt
#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
#define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
#define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
-#define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
+#define LOOPX(f) return (PL_bufptr = force_word(s,WORD,TRUE,FALSE), \
+ pl_yylval.ival=f, \
+ PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
+ REPORT((int)LOOPEX))
#define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
#define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
#define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
#define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
#define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
#define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
+#define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
#define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
#define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
#define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
PL_last_lop_op = f; \
if (*s == '(') \
return REPORT( (int)FUNC1 ); \
- s = PEEKSPACE(s); \
+ s = skipspace(s); \
return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
}
#define UNI(f) UNI3(f,XTERM,1)
/*
* S_ao
*
- * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
- * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
+ * This subroutine looks for an '=' next to the operator that has just been
+ * parsed and turns it into an ASSIGNOP if it finds one.
*/
STATIC int
/*
* S_lop
* Build a list operator (or something that might be one). The rules:
- * - if we have a next token, then it's a list operator [why?]
+ * - if we have a next token, then it's a list operator (no parens) for
+ * which the next token has already been parsed; e.g.,
+ * sort foo @args
+ * sort foo (@args)
* - if the next thing is an opening paren, then it's a function
* - else it's a list operator
*/
pl_yylval.ival = f;
CLINE;
- PL_expect = x;
PL_bufptr = s;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = (OPCODE)f;
if (PL_nexttoke)
goto lstop;
+ PL_expect = x;
if (*s == '(')
return REPORT(FUNC);
- s = PEEKSPACE(s);
+ s = skipspace(s);
if (*s == '(')
return REPORT(FUNC);
else {
PL_nexttoke++;
if (PL_lex_state != LEX_KNOWNEXT) {
PL_lex_defer = PL_lex_state;
- PL_lex_expect = PL_expect;
PL_lex_state = LEX_KNOWNEXT;
}
}
* a keyword (do this if the word is a label, e.g. goto FOO)
* int allow_pack : if true, : characters will also be allowed (require,
* use, etc. do this)
- * int allow_initial_tick : used by the "sub" lexer only.
*/
STATIC char *
PERL_ARGS_ASSERT_FORCE_WORD;
- start = SKIPSPACE1(start);
+ start = skipspace(start);
s = start;
if (isIDFIRST_lazy_if(s,UTF) ||
(allow_pack && *s == ':') )
return start;
}
if (token == METHOD) {
- s = SKIPSPACE1(s);
+ s = skipspace(s);
if (*s == '(')
PL_expect = XTERM;
else {
warnings if the symbol must be introduced in an eval.
GSAR 96-10-12 */
gv_fetchpvn_flags(s, len,
- (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
+ (PL_in_eval ? GV_ADDMULTI
: GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
kind == '$' ? SVt_PV :
kind == '@' ? SVt_PVAV :
PERL_ARGS_ASSERT_FORCE_VERSION;
- s = SKIPSPACE1(s);
+ s = skipspace(s);
d = s;
if (*d == 'v')
version = newSVOP(OP_CONST, 0, ver);
}
else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
- (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
+ (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
{
PL_bufptr = s;
if (errstr)
*d++ = '\t';
break;
case 'e':
- *d++ = ASCII_TO_NATIVE('\033');
+ *d++ = ESC_NATIVE;
break;
case 'a':
*d++ = '\a';
*/
STATIC int
-S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
+S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
{
char *s = start + (*start == '$');
char tmpbuf[sizeof PL_tokenbuf];
STRLEN len;
GV* indirgv;
+ /* Mustn't actually add anything to a symbol table.
+ But also don't want to "initialise" any placeholder
+ constants that might already be there into full
+ blown PVGVs with attached PVCV. */
+ GV * const gv =
+ ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
PERL_ARGS_ASSERT_INTUIT_METHOD;
if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
isUPPER(*PL_tokenbuf))
return 0;
- s = PEEKSPACE(s);
+ s = skipspace(s);
PL_bufptr = start;
PL_expect = XREF;
return *s == '(' ? FUNCMETH : METHOD;
return 0;
/* filehandle or package name makes it a method */
if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
- s = PEEKSPACE(s);
+ s = skipspace(s);
if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
return 0; /* no assumptions -- "=>" quotes bareword */
bare_package:
if (gv && GvCV(gv)) {
SV * const sv = cv_const_sv(GvCV(gv));
if (sv)
- pkgname = SvPV_const(sv, len);
+ return gv_stashsv(sv, 0);
}
return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
is_use ? "use" : "no"));
PL_expect = XTERM;
- s = SKIPSPACE1(s);
+ s = skipspace(s);
if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
s = force_version(s, TRUE);
if (*s == ';' || *s == '}'
- || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
+ || (s = skipspace(s), (*s == ';' || *s == '}'))) {
NEXTVAL_NEXTTOKE.opval = NULL;
force_next(WORD);
}
pl_yylval = PL_nextval[PL_nexttoke];
if (!PL_nexttoke) {
PL_lex_state = PL_lex_defer;
- PL_expect = PL_lex_expect;
PL_lex_defer = LEX_NORMAL;
}
{
PL_lex_starts = 0;
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (PL_lex_casemods == 1 && PL_lex_inpat)
- OPERATOR(',');
+ TOKEN(',');
else
- Aop(OP_CONCAT);
+ AopNOASSIGN(OP_CONCAT);
}
else
return yylex();
s = PL_bufptr;
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (!PL_lex_casemods && PL_lex_inpat)
- OPERATOR(',');
+ TOKEN(',');
else
- Aop(OP_CONCAT);
+ AopNOASSIGN(OP_CONCAT);
}
return yylex();
if (PL_lex_starts++) {
/* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
if (!PL_lex_casemods && PL_lex_inpat)
- OPERATOR(',');
+ TOKEN(',');
else
- Aop(OP_CONCAT);
+ AopNOASSIGN(OP_CONCAT);
}
else {
PL_bufptr = s;
* line contains "Perl" rather than "perl" */
if (!d) {
for (d = ipathend-4; d >= ipath; --d) {
- if ((*d == 'p' || *d == 'P')
+ if (isALPHA_FOLD_EQ(*d, 'p')
&& !ibcmp(d, "perl", 4))
{
break;
!= PL_unicode)
baduni = TRUE;
}
- if (baduni || *d1 == 'M' || *d1 == 'm') {
+ if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
const char * const m = d1;
while (*d1 && !isSPACE(*d1))
d1++;
}
else if (*s == '>') {
s++;
- s = SKIPSPACE1(s);
+ s = skipspace(s);
if (FEATURE_POSTDEREF_IS_ENABLED && (
((*s == '$' || *s == '&') && s[1] == '*')
||(*s == '$' && s[1] == '#' && s[2] == '*')
case XATTRTERM:
PL_expect = XTERMBLOCK;
grabattrs:
- s = PEEKSPACE(s);
+ s = skipspace(s);
attrs = NULL;
while (isIDFIRST_lazy_if(s,UTF)) {
I32 tmp;
newSVOP(OP_CONST, 0,
sv));
}
- s = PEEKSPACE(d);
+ s = skipspace(d);
if (*s == ':' && s[1] != ':')
- s = PEEKSPACE(s+1);
+ s = skipspace(s+1);
else if (s == d)
break; /* require real whitespace or :'s */
/* XXX losing whitespace on sequential attributes here */
PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
else
PL_expect = XTERM;
- s = SKIPSPACE1(s);
+ s = skipspace(s);
PL_lex_allbrackets++;
TOKEN('(');
case ';':
TOKEN(0);
CLINE;
s++;
- OPERATOR(';');
+ PL_expect = XSTATE;
+ TOKEN(';');
case ')':
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
TOKEN(0);
s++;
PL_lex_allbrackets--;
- s = SKIPSPACE1(s);
+ s = skipspace(s);
if (*s == '{')
PREBLOCK(')');
TERM(')');
}
}
/* FALLTHROUGH */
- case XATTRBLOCK:
- case XBLOCK:
- PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
- PL_lex_allbrackets++;
- PL_expect = XSTATE;
- break;
case XATTRTERM:
case XTERMBLOCK:
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
PL_lex_allbrackets++;
PL_expect = XSTATE;
break;
+ case XATTRBLOCK:
+ case XBLOCK:
+ PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
+ PL_lex_allbrackets++;
+ PL_expect = XSTATE;
+ break;
case XBLOCKTERM:
PL_lex_brackstack[PL_lex_brackets++] = XTERM;
PL_lex_allbrackets++;
else
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
PL_lex_allbrackets++;
- s = SKIPSPACE1(s);
+ s = skipspace(s);
if (*s == '}') {
if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
PL_expect = XTERM;
}
OPERATOR(HASHBRACK);
}
+ if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
+ /* ${...} or @{...} etc., but not print {...} */
+ PL_expect = XTERM;
+ break;
+ }
/* This hack serves to disambiguate a pair of curlies
* as being a block or an anon hash. Normally, expectation
* determines that, but in cases where we're not in a
if (*s == '\'' || *s == '"' || *s == '`') {
/* common case: get past first string, handling escapes */
for (t++; t < PL_bufend && *t != *s;)
- if (*t++ == '\\' && (*t == '\\' || *t == *s))
+ if (*t++ == '\\')
t++;
t++;
}
{
const char tmp = *s;
if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
- s = SKIPSPACE1(s);
+ s = skipspace(s);
if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
&& intuit_more(s)) {
while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
t++;
if (*t++ == ',') {
- PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
+ PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
while (t < PL_bufend && *t != ']')
t++;
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
PREREF('@');
}
if (PL_lex_state == LEX_NORMAL)
- s = SKIPSPACE1(s);
+ s = skipspace(s);
if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
if (*s == '{')
PL_tokenbuf[0] = '%';
}
/* avoid v123abc() or $h{v1}, allow C<print v10;> */
if (!isALPHA(*start) && (PL_expect == XTERM
- || PL_expect == XREF || PL_expect == XSTATE
+ || PL_expect == XSTATE
|| PL_expect == XTERMORDORDOR)) {
GV *const gv = gv_fetchpvn_flags(s, start - s,
UTF ? SVf_UTF8 : 0, SVt_PVCV);
} else if (result == KEYWORD_PLUGIN_STMT) {
pl_yylval.opval = o;
CLINE;
- PL_expect = XSTATE;
+ if (!PL_nexttoke) PL_expect = XSTATE;
return REPORT(PLUGSTMT);
} else if (result == KEYWORD_PLUGIN_EXPR) {
pl_yylval.opval = o;
CLINE;
- PL_expect = XOPERATOR;
+ if (!PL_nexttoke) PL_expect = XOPERATOR;
return REPORT(PLUGEXPR);
} else {
Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
just_a_word: {
int pkgname = 0;
const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
- const char penultchar =
- lastchar && PL_bufptr - 2 >= PL_linestart
- ? PL_bufptr[-2]
- : 0;
+ bool safebw;
/* Get the rest if it looks like a package qualifier */
no_op("Bareword",s);
}
- /* Look for a subroutine with this name in current package,
- unless this is a lexical sub, or name is "Foo::",
+ /* See if the name is "Foo::",
in which case Foo is a bareword
(and a package name). */
PL_tokenbuf[len] = '\0';
gv = NULL;
gvp = 0;
+ safebw = TRUE;
}
else {
- if (!lex && !gv) {
- /* Mustn't actually add anything to a symbol table.
- But also don't want to "initialise" any placeholder
- constants that might already be there into full
- blown PVGVs with attached PVCV. */
- gv = gv_fetchpvn_flags(PL_tokenbuf, len,
- GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ),
- SVt_PVCV);
- }
- len = 0;
+ safebw = FALSE;
}
/* if we saw a global override before, get the right name */
if (!sv)
sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
- len ? len : strlen(PL_tokenbuf));
+ len);
if (gvp) {
SV * const tmp_sv = sv;
sv = newSVpvs("CORE::GLOBAL::");
pl_yylval.opval->op_private = OPpCONST_BARE;
/* And if "Foo::", then that's what it certainly is. */
- if (len)
+ if (safebw)
goto safe_bareword;
if (!off)
{
OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
const_op->op_private = OPpCONST_BARE;
- rv2cv_op = newCVREF(0, const_op);
- cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0);
+ rv2cv_op =
+ newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
+ cv = lex
+ ? isGV(gv)
+ ? GvCV(gv)
+ : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
+ ? (CV *)SvRV(gv)
+ : (CV *)gv
+ : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
}
+ /* Use this var to track whether intuit_method has been
+ called. intuit_method returns 0 or > 255. */
+ tmp = 1;
+
/* See if it's the indirect object for a list operator. */
if (PL_oldoldbufptr &&
bool immediate_paren = *s == '(';
/* (Now we can afford to cross potential line boundary.) */
- s = SKIPSPACE2(s,nextPL_nextwhite);
+ s = skipspace(s);
/* Two barewords in a row may indicate method call. */
if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
- (tmp = intuit_method(s, gv, cv))) {
- op_free(rv2cv_op);
- if (tmp == METHOD && !PL_lex_allbrackets &&
- PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
- PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
- return REPORT(tmp);
+ (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
+ goto method;
}
/* If not a declared subroutine, it's an indirect object. */
if (*s == '=' && s[1] == '>' && !pkgname) {
op_free(rv2cv_op);
CLINE;
- /* This is our own scalar, created a few lines above,
- so this is safe. */
- SvREADONLY_off(cSVOPx(pl_yylval.opval)->op_sv);
- sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
- if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
- SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
- SvREADONLY_on(cSVOPx(pl_yylval.opval)->op_sv);
+ if (gvp || (lex && !off)) {
+ assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
+ /* This is our own scalar, created a few lines
+ above, so this is safe. */
+ SvREADONLY_off(sv);
+ sv_setpv(sv, PL_tokenbuf);
+ if (UTF && !IN_BYTES
+ && is_utf8_string((U8*)PL_tokenbuf, len))
+ SvUTF8_on(sv);
+ SvREADONLY_on(sv);
+ }
TERM(WORD);
}
}
NEXTVAL_NEXTTOKE.opval =
off ? rv2cv_op : pl_yylval.opval;
- PL_expect = XOPERATOR;
if (off)
op_free(pl_yylval.opval), force_next(PRIVATEREF);
else op_free(rv2cv_op), force_next(WORD);
/* If followed by a bareword, see if it looks like indir obj. */
- if (!orig_keyword
+ if (tmp == 1 && !orig_keyword
&& (isIDFIRST_lazy_if(s,UTF) || *s == '$')
- && (tmp = intuit_method(s, gv, cv))) {
+ && (tmp = intuit_method(s, lex ? NULL : sv, cv))) {
+ method:
+ if (lex && !off) {
+ assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
+ SvREADONLY_off(sv);
+ sv_setpvn(sv, PL_tokenbuf, len);
+ if (UTF && !IN_BYTES
+ && is_utf8_string((U8*)PL_tokenbuf, len))
+ SvUTF8_on (sv);
+ else SvUTF8_off(sv);
+ }
op_free(rv2cv_op);
if (tmp == METHOD && !PL_lex_allbrackets &&
PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
/* Not a method, so call it a subroutine (if defined) */
if (cv) {
- if (lastchar == '-' && penultchar != '-') {
- const STRLEN l = len ? len : strlen(PL_tokenbuf);
- Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Ambiguous use of -%"UTF8f" resolved as -&%"UTF8f"()",
- UTF8fARG(UTF, l, PL_tokenbuf),
- UTF8fARG(UTF, l, PL_tokenbuf));
- }
/* Check for a constant sub */
if ((sv = cv_const_sv_or_av(cv))) {
its_constant:
PREBLOCK(DEFAULT);
case KEY_do:
- s = SKIPSPACE1(s);
+ s = skipspace(s);
if (*s == '{')
PRETERMBLOCK(DO);
if (*s != '\'') {
1, &len);
if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
&& !keyword(PL_tokenbuf + 1, len, 0)) {
- d = SKIPSPACE1(d);
+ d = skipspace(d);
if (*d == '(') {
force_ident_maybe_lex('&');
s = d;
UNI(OP_DBMCLOSE);
case KEY_dump:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_DUMP);
case KEY_else:
UNI(OP_EXIT);
case KEY_eval:
- s = SKIPSPACE1(s);
+ s = skipspace(s);
if (*s == '{') { /* block eval */
PL_expect = XTERMBLOCK;
UNIBRACK(OP_ENTERTRY);
if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
return REPORT(0);
pl_yylval.ival = CopLINE(PL_curcop);
- s = SKIPSPACE1(s);
+ s = skipspace(s);
if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
char *p = s;
else if ((PL_bufend - p) >= 4 &&
strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
p += 3;
- p = PEEKSPACE(p);
+ p = skipspace(p);
/* skip optional package name, as in "for my abc $x (..)" */
if (isIDFIRST_lazy_if(p,UTF)) {
p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
- p = PEEKSPACE(p);
+ p = skipspace(p);
}
if (*p != '$')
Perl_croak(aTHX_ "Missing $ on loop variable");
LOP(OP_GREPSTART, XREF);
case KEY_goto:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_GOTO);
case KEY_gmtime:
LOP(OP_KILL,XTERM);
case KEY_last:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_LAST);
case KEY_lc:
case KEY_my:
case KEY_state:
PL_in_my = (U16)tmp;
- s = SKIPSPACE1(s);
+ s = skipspace(s);
if (isIDFIRST_lazy_if(s,UTF)) {
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
OPERATOR(MY);
case KEY_next:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_NEXT);
case KEY_ne:
case KEY_no:
s = tokenize_use(0, s);
- TERM(USE);
+ TOKEN(USE);
case KEY_not:
- if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
+ if (*s == '(' || (s = skipspace(s), *s == '('))
FUN1(OP_NOT);
else {
if (!PL_lex_allbrackets &&
}
case KEY_open:
- s = SKIPSPACE1(s);
+ s = skipspace(s);
if (isIDFIRST_lazy_if(s,UTF)) {
const char *t;
d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
case KEY_package:
s = force_word(s,WORD,FALSE,TRUE);
- s = SKIPSPACE1(s);
+ s = skipspace(s);
s = force_strict_version(s);
- PL_lex_expect = XBLOCK;
- OPERATOR(PACKAGE);
+ PREBLOCK(PACKAGE);
case KEY_pipe:
LOP(OP_PIPE_OP,XTERM);
OLDLOP(OP_RETURN);
case KEY_require:
- s = SKIPSPACE1(s);
- PL_expect = XOPERATOR;
+ s = skipspace(s);
if (isDIGIT(*s)) {
s = force_version(s, FALSE);
}
}
else
pl_yylval.ival = 0;
- PL_expect = XTERM;
+ PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
PL_bufptr = s;
PL_last_uni = PL_oldbufptr;
PL_last_lop_op = OP_REQUIRE;
UNI(OP_RESET);
case KEY_redo:
- PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_REDO);
case KEY_rename:
case KEY_sort:
checkcomma(s,PL_tokenbuf,"subroutine name");
- s = SKIPSPACE1(s);
+ s = skipspace(s);
PL_expect = XTERM;
s = force_word(s,WORD,TRUE,TRUE);
LOP(OP_SORT,XREF);
case KEY_use:
s = tokenize_use(1, s);
- OPERATOR(USE);
+ TOKEN(USE);
case KEY_values:
UNI(OP_VALUES);
pl_yylval.opval->op_private = OPpCONST_ENTERED;
if (pit != '&')
gv_fetchsv(sym,
- (PL_in_eval
- ? (GV_ADDMULTI | GV_ADDINEVAL)
- : GV_ADDMULTI
- ),
+ GV_ADDMULTI,
((PL_tokenbuf[0] == '$') ? SVt_PV
: (PL_tokenbuf[0] == '@') ? SVt_PVAV
: SVt_PVHV));
pl_yylval.opval->op_private = OPpCONST_ENTERED;
if (pit != '&')
gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
- (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
+ (PL_in_eval ? GV_ADDMULTI : GV_ADD)
| ( UTF ? SVf_UTF8 : 0 ),
((PL_tokenbuf[0] == '$') ? SVt_PV
: (PL_tokenbuf[0] == '@') ? SVt_PVAV
s++;
if (*s == ',') {
GV* gv;
+ PADOFFSET off;
if (keyword(w, s - w, 0))
return;
gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
if (gv && GvCVu(gv))
return;
+ if (s - w <= 254) {
+ char tmpbuf[256];
+ Copy(w, tmpbuf+1, s - w, char);
+ *tmpbuf = '&';
+ off = pad_findmy_pvn(tmpbuf, s-w+1, UTF ? SVf_UTF8 : 0);
+ if (off != NOT_IN_PAD) return;
+ }
Perl_croak(aTHX_ "No comma allowed after %s", what);
}
}
PERL_ARGS_ASSERT_SCAN_IDENT;
if (isSPACE(*s))
- s = PEEKSPACE(s);
+ s = skipspace(s);
if (isDIGIT(*s)) {
while (isDIGIT(*s)) {
if (d >= e)
s++;
orig_copline = CopLINE(PL_curcop);
if (s < PL_bufend && isSPACE(*s)) {
- s = PEEKSPACE(s);
+ s = skipspace(s);
}
}
*d = '\0';
tmp_copline = CopLINE(PL_curcop);
if (s < PL_bufend && isSPACE(*s)) {
- s = PEEKSPACE(s);
+ s = skipspace(s);
}
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
/* ${foo[0]} and ${foo{bar}} notation. */
if ( !tmp_copline )
tmp_copline = CopLINE(PL_curcop);
if (s < PL_bufend && isSPACE(*s)) {
- s = PEEKSPACE(s);
+ s = skipspace(s);
}
/* Expect to find a closing } after consuming any trailing whitespace.
else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
PL_bufend[-1] = '\n';
#endif
- if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) {
+ if (*s == term && PL_bufend-s >= len
+ && memEQ(s,PL_tokenbuf + 1,len)) {
SvREFCNT_dec(PL_linestr);
PL_linestr = linestr_save;
PL_linestart = SvPVX(linestr_save);
++d;
intro_sym:
gv = gv_fetchpv(d,
- (PL_in_eval
- ? (GV_ADDMULTI | GV_ADDINEVAL)
- : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
+ GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
SVt_PV);
PL_lex_op = readline_overriden
? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
/* skip space before the delimiter */
if (isSPACE(*s)) {
- s = PEEKSPACE(s);
+ s = skipspace(s);
}
/* mark where we are, in case we need to report errors */
\d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
\.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
- 0b[01](_?[01])*
- 0[0-7](_?[0-7])*
- 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
+ 0b[01](_?[01])* binary integers
+ 0[0-7](_?[0-7])* octal integers
+ 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
+ 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
thing it reads.
const char *base, *Base, *max;
/* check for hex */
- if (s[1] == 'x' || s[1] == 'X') {
+ if (isALPHA_FOLD_EQ(s[1], 'x')) {
shift = 4;
s += 2;
just_zero = FALSE;
- } else if (s[1] == 'b' || s[1] == 'B') {
+ } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
shift = 1;
s += 2;
just_zero = FALSE;
}
/* check for a decimal in disguise */
- else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
+ else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
goto decimal;
/* so it must be octal */
else {
/* this could be hexfp, but peek ahead
* to avoid matching ".." */
-#define HEXFP_PEEK(s) \
- (((s[0] == '.') && \
- (isXDIGIT(s[1]) || s[1] == 'p' || s[1] == 'P')) \
- || s[0] == 'p' || s[0] == 'P')
if (UNLIKELY(HEXFP_PEEK(s))) {
goto out;
}
total_bits--;
}
- if (total_bits > 0 && (*h == 'p' || *h == 'P')) {
+ if (total_bits > 0 && (isALPHA_FOLD_EQ(*h, 'p'))) {
bool negexp = FALSE;
h++;
if (*h == '+')
}
/* read exponent part, if present */
- if (((*s == 'e' || *s == 'E') ||
- UNLIKELY(hexfp && (*s == 'p' || *s == 'P'))) &&
- strchr("+-0123456789_", s[1])) {
+ if ((isALPHA_FOLD_EQ(*s, 'e')
+ || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
+ && strchr("+-0123456789_", s[1]))
+ {
floatit = TRUE;
/* regardless of whether user said 3E5 or 3e5, use lower 'e',
ditto for p (hexfloats) */
- if ((*s == 'e' || *s == 'E')) {
+ if ((isALPHA_FOLD_EQ(*s, 'e'))) {
/* At least some Mach atof()s don't grok 'E' */
*d++ = 'e';
}
- else if (UNLIKELY(hexfp && (*s == 'p' || *s == 'P'))) {
+ else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
*d++ = 'p';
}
* C preprocessor can make decisions based on it. It is only
* defined if the system supports long doubles.
*/
+/* HAS_LDEXPL:
+ * This symbol, if defined, indicates that the ldexpl routine is
+ * available to shift a long double floating-point number
+ * by an integral power of 2.
+ */
/* LONG_DOUBLEKIND:
* LONG_DOUBLEKIND will be one of
* LONG_DOUBLE_IS_DOUBLE
* LONG_DOUBLE_IS_UNKNOWN_FORMAT
* It is only defined if the system supports long doubles.
*/
+/*#define HAS_LDEXPL / **/
/*#define HAS_LONG_DOUBLE / **/
#ifdef HAS_LONG_DOUBLE
#define LONG_DOUBLESIZE 8 /**/
/*#define PWGECOS / **/
/*#define PWPASSWD / **/
+/* I_QUADMATH:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <quadmath.h>.
+ */
+/*#define I_QUADMATH / **/
+
/* I_SYS_ACCESS:
* This symbol, if defined, indicates to the C program that it should
* include <sys/access.h>.
*/
/*#define HAS__FWALK / **/
+/* HAS_ACOSH:
+ * This symbol, if defined, indicates that the acosh routine is
+ * available to do the inverse hyperbolic cosine function.
+ */
+/*#define HAS_ACOSH / **/
+
/* HAS_AINTL:
* This symbol, if defined, indicates that the aintl routine is
* available. If copysignl is also present we can emulate modfl.
*/
/*#define FCNTL_CAN_LOCK / **/
+/* HAS_FEGETROUND:
+ * This symbol, if defined, indicates that the fegetround routine is
+ * available to return the macro corresponding to the current rounding
+ * mode.
+ */
+/*#define HAS_FEGETROUND / **/
+
/* HAS_FINITE:
* This symbol, if defined, indicates that the finite routine is
* available to check whether a double is finite (non-infinity non-NaN).
*/
/*#define HAS_FP_CLASS / **/
+/* HAS_FP_CLASSL:
+ * This symbol, if defined, indicates that the fp_classl routine is
+ * available to classify long doubles. Available for example in
+ * Digital UNIX. See for possible values HAS_FP_CLASS.
+ */
+/*#define HAS_FP_CLASSL / **/
+
/* HAS_FPCLASS:
* This symbol, if defined, indicates that the fpclass routine is
* available to classify doubles. Available for example in Solaris/SVR4.
* FP_NAN NaN
*
*/
-/*#define HAS_FPCLASSIFY / **/
+/* HAS_FP_CLASSIFY:
+ * This symbol, if defined, indicates that the fp_classify routine is
+ * available to classify doubles. The values are defined in <math.h>
+ *
+ * FP_NORMAL Normalized
+ * FP_ZERO Zero
+ * FP_INFINITE Infinity
+ * FP_SUBNORMAL Denormalized
+ * FP_NAN NaN
+ *
+ */
+/*#define HAS_FPCLASSIFY / **/
+/*#define HAS_FP_CLASSIFY / **/
/* HAS_FPCLASSL:
* This symbol, if defined, indicates that the fpclassl routine is
*/
/*#define HAS_FPCLASSL / **/
+/* HAS_FPGETROUND:
+ * This symbol, if defined, indicates that the fpgetround routine is
+ * available to get the floating point rounding mode.
+ */
+/*#define HAS_FPGETROUND / **/
+
/* HAS_FPOS64_T:
* This symbol will be defined if the C compiler supports fpos64_t.
*/
*/
/*#define HAS_FREXPL / **/
-/* HAS_LDEXPL:
- * This symbol, if defined, indicates that the ldexpl routine is
- * available to shift a long double floating-point number
- * by an integral power of 2.
- */
-/*#define HAS_LDEXPL / **/
-
/* HAS_STRUCT_FS_DATA:
* This symbol, if defined, indicates that the struct fs_data
* to do statfs() is supported.
*/
/*#define HAS_ISFINITE / **/
+/* HAS_ISFINITEL:
+ * This symbol, if defined, indicates that the isfinitel routine is
+ * available to check whether a long double is finite.
+ * (non-infinity non-NaN).
+ */
+/*#define HAS_ISFINITEL / **/
+
/* HAS_ISINF:
* This symbol, if defined, indicates that the isinf routine is
* available to check whether a double is an infinity.
*/
/*#define HAS_ISINF / **/
+/* HAS_ISINFL:
+ * This symbol, if defined, indicates that the isinfl routine is
+ * available to check whether a long double is an infinity.
+ */
+/*#define HAS_ISINFL / **/
+
/* HAS_ISNAN:
* This symbol, if defined, indicates that the isnan routine is
* available to check whether a double is a NaN.
*/
/*#define HAS_ISNANL / **/
+/* HAS_J0:
+ * This symbol, if defined, indicates to the C program that the
+ * j0() function is available for Bessel functions of the first
+ * kind of the order zero, for doubles.
+ */
+/* HAS_J0L:
+ * This symbol, if defined, indicates to the C program that the
+ * j0l() function is available for Bessel functions of the first
+ * kind of the order zero, for long doubles.
+ */
+/*#define HAS_J0 / **/
+/*#define HAS_J0L / **/
+
/* HAS_LDBL_DIG:
* This symbol, if defined, indicates that this system's <float.h>
* or <limits.h> defines the symbol LDBL_DIG, which is the number
*/
/*#define HAS_TIMEGM / **/
+/* HAS_TRUNCL:
+ * This symbol, if defined, indicates that the truncl routine is
+ * available. If copysignl is also present we can emulate modfl.
+ */
+/*#define HAS_TRUNCL / **/
+
/* U32_ALIGNMENT_REQUIRED:
* This symbol, if defined, indicates that you must access
* character data through U32-aligned pointers.
#define DB_VERSION_MINOR_CFG 0 /**/
#define DB_VERSION_PATCH_CFG 0 /**/
+/* I_FENV:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <fenv.h> to get the floating point environment definitions.
+ */
+/*#define I_FENV / **/
+
/* I_FP:
* This symbol, if defined, indicates that <fp.h> exists and
* should be included.
*/
/*#define I_STDBOOL / **/
+/* I_STDINT:
+ * This symbol, if defined, indicates that <stdint.h> exists and
+ * should be included.
+ */
+/*#define I_STDINT / **/
+
/* I_SUNMATH:
* This symbol, if defined, indicates that <sunmath.h> exists and
* should be included.
/*#define USE_LONG_DOUBLE / **/
#endif
+/* USE_QUADMATH:
+ * This symbol, if defined, indicates that the quadmath library should
+ * be used when available.
+ */
+#ifndef USE_QUADMATH
+/*#define USE_QUADMATH / **/
+#endif
+
/* USE_MORE_BITS:
* This symbol, if defined, indicates that 64-bit interfaces and
* long doubles should be used when available.
#endif
/* Generated from:
- * 5f68e17a9d9e989b824daf55d2adcad3b7af2becfa8f627c6cb1d0e376f7e1a5 config_h.SH
- * 98397a7d818a024628d6b34e5903a8f408da96601a2a19471c480511f3c8d914 uconfig.sh
+ * d7da79ac72d2191d6814ec98688e342f20eba70c64292c2e0b6b5622cdf3b6e6 config_h.SH
+ * a3cd0b705a952f6915cc1424cc116d4183481f54ba9605415baf93bc57e12122 uconfig.sh
* ex: set ro: */
d__fwalk='undef'
d_access='undef'
d_accessx='undef'
+d_acosh='undef'
d_aintl='undef'
d_alarm='undef'
d_archlib='undef'
d_fd_macros='undef'
d_fd_set='undef'
d_fds_bits='undef'
+d_fegetround='undef'
d_fgetpos='undef'
d_finite='undef'
d_finitel='undef'
d_flockproto='undef'
d_fork='define'
d_fp_class='undef'
+d_fp_classify='undef'
+d_fp_classl='undef'
d_fpathconf='undef'
d_fpclass='undef'
d_fpclassify='undef'
d_fpclassl='undef'
+d_fpgetround='undef'
d_fpos64_t='undef'
d_frexpl='undef'
d_fs_data_s='undef'
d_isascii='undef'
d_isblank='undef'
d_isfinite='undef'
+d_isfinitel='undef'
d_isinf='undef'
+d_isinfl='undef'
d_isnan='undef'
d_isnanl='undef'
+d_j0='undef'
+d_j0l='undef'
d_killpg='undef'
d_lchown='undef'
d_ldbl_dig='undef'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
d_truncate='undef'
+d_truncl='undef'
d_ttyname_r='undef'
d_tzname='undef'
d_u32align='define'
i_dlfcn='undef'
i_execinfo='undef'
i_fcntl='undef'
+i_fenv='undef'
i_float='undef'
i_fp='undef'
i_fp_class='undef'
i_prot='undef'
i_pthread='undef'
i_pwd='undef'
+i_quadmath='undef'
i_rpcsvcdbm='undef'
i_sgtty='undef'
i_shadow='undef'
i_stdarg='define'
i_stdbool='undef'
i_stddef='define'
+i_stdint='undef'
i_stdlib='define'
i_string='define'
i_sunmath='undef'
useopcode='true'
useperlio='undef'
useposix='true'
+usequadmath='undef'
usereentrant='undef'
userelocatableinc='undef'
useshrplib='false'
d__fwalk='undef'
d_access='undef'
d_accessx='undef'
+d_acosh='undef'
d_aintl='undef'
d_alarm='undef'
d_archlib='undef'
d_fd_macros='undef'
d_fd_set='undef'
d_fds_bits='undef'
+d_fegetround='undef'
d_fgetpos='undef'
d_finite='undef'
d_finitel='undef'
d_flockproto='undef'
d_fork='define'
d_fp_class='undef'
+d_fp_classify='undef'
+d_fp_classl='undef'
d_fpathconf='undef'
d_fpclass='undef'
d_fpclassify='undef'
d_fpclassl='undef'
+d_fpgetround='undef'
d_fpos64_t='undef'
d_frexpl='undef'
d_fs_data_s='undef'
d_isascii='undef'
d_isblank='undef'
d_isfinite='undef'
+d_isfinitel='undef'
d_isinf='undef'
+d_isinfl='undef'
d_isnan='undef'
d_isnanl='undef'
+d_j0='undef'
+d_j0l='undef'
d_killpg='undef'
d_lchown='undef'
d_ldbl_dig='undef'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
d_truncate='undef'
+d_truncl='undef'
d_ttyname_r='undef'
d_tzname='undef'
d_u32align='define'
i_dlfcn='undef'
i_execinfo='undef'
i_fcntl='undef'
+i_fenv='undef'
i_float='undef'
i_fp='undef'
i_fp_class='undef'
i_prot='undef'
i_pthread='undef'
i_pwd='undef'
+i_quadmath='undef'
i_rpcsvcdbm='undef'
i_sgtty='undef'
i_shadow='undef'
i_stdarg='define'
i_stdbool='undef'
i_stddef='define'
+i_stdint='undef'
i_stdlib='define'
i_string='define'
i_sunmath='undef'
useopcode='true'
useperlio='undef'
useposix='true'
+usequadmath='undef'
usereentrant='undef'
userelocatableinc='undef'
useshrplib='false'
# define DEL_NATIVE 0x7F /* U+007F */
# define CR_NATIVE 0x0D /* U+000D */
# define LF_NATIVE 0x0A /* U+000A */
+# define VT_NATIVE 0x0B /* U+000B */
+# define ESC_NATIVE 0x1B /* U+001B */
# define LATIN_SMALL_LETTER_SHARP_S_NATIVE 0xDF /* U+00DF */
# define LATIN_SMALL_LETTER_A_WITH_RING_ABOVE_NATIVE 0xE5 /* U+00E5 */
# define LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE_NATIVE 0xC5 /* U+00C5 */
# define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS_NATIVE 0xFF /* U+00FF */
# define MICRO_SIGN_NATIVE 0xB5 /* U+00B5 */
+# define MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C 0x7E /* The max code point that isPRINT_A */
#endif /* ASCII/Latin1 */
# define DEL_NATIVE 0x07 /* U+007F */
# define CR_NATIVE 0x0D /* U+000D */
# define LF_NATIVE 0x15 /* U+000A */
+# define VT_NATIVE 0x0B /* U+000B */
+# define ESC_NATIVE 0x27 /* U+001B */
# define LATIN_SMALL_LETTER_SHARP_S_NATIVE 0x59 /* U+00DF */
# define LATIN_SMALL_LETTER_A_WITH_RING_ABOVE_NATIVE 0x47 /* U+00E5 */
# define LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE_NATIVE 0x67 /* U+00C5 */
# define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS_NATIVE 0xDF /* U+00FF */
# define MICRO_SIGN_NATIVE 0xA0 /* U+00B5 */
+# define MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C 0xF9 /* The max code point that isPRINT_A */
#endif /* EBCDIC 1047 */
# define DEL_NATIVE 0x07 /* U+007F */
# define CR_NATIVE 0x0D /* U+000D */
# define LF_NATIVE 0x25 /* U+000A */
+# define VT_NATIVE 0x0B /* U+000B */
+# define ESC_NATIVE 0x27 /* U+001B */
# define LATIN_SMALL_LETTER_SHARP_S_NATIVE 0x59 /* U+00DF */
# define LATIN_SMALL_LETTER_A_WITH_RING_ABOVE_NATIVE 0x47 /* U+00E5 */
# define LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE_NATIVE 0x67 /* U+00C5 */
# define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS_NATIVE 0xDF /* U+00FF */
# define MICRO_SIGN_NATIVE 0xA0 /* U+00B5 */
+# define MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C 0xF9 /* The max code point that isPRINT_A */
#endif /* EBCDIC 037 */
# define DEL_NATIVE 0x07 /* U+007F */
# define CR_NATIVE 0x0D /* U+000D */
# define LF_NATIVE 0x15 /* U+000A */
+# define VT_NATIVE 0x0B /* U+000B */
+# define ESC_NATIVE 0x27 /* U+001B */
# define LATIN_SMALL_LETTER_SHARP_S_NATIVE 0x59 /* U+00DF */
# define LATIN_SMALL_LETTER_A_WITH_RING_ABOVE_NATIVE 0x47 /* U+00E5 */
# define LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE_NATIVE 0x67 /* U+00C5 */
# define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS_NATIVE 0xDF /* U+00FF */
# define MICRO_SIGN_NATIVE 0xA0 /* U+00B5 */
+# define MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C 0xFF /* The max code point that isPRINT_A */
#endif /* EBCDIC POSIX-BC */
void
Perl_croak_xs_usage(const CV *const cv, const char *const params)
{
- const GV *const gv = CvGV(cv);
+ /* Avoid CvGV as it requires aTHX. */
+ const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv;
PERL_ARGS_ASSERT_CROAK_XS_USAGE;
- if (gv) {
+ if (gv) got_gv: {
const HV *const stash = GvSTASH(gv);
if (HvNAME_get(stash))
Perl_croak_nocontext("Usage: %"HEKf"(%s)",
HEKfARG(GvNAME_HEK(gv)), params);
} else {
+ dTHX;
+ if ((gv = CvGV(cv))) goto got_gv;
+
/* Pants. I don't think that it should be possible to get here. */
/* diag_listed_as: SKIPME */
- Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
+ Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
}
}
SV*
Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none, SV* invlist, U8* const flags_p)
{
+
+ /*NOTE NOTE NOTE - If you want to use "return" in this routine you MUST
+ * use the following define */
+
+#define CORE_SWASH_INIT_RETURN(x) \
+ PL_curpm= old_PL_curpm; \
+ return x
+
/* Initialize and return a swash, creating it if necessary. It does this
* by calling utf8_heavy.pl in the general case. The returned value may be
* the swash's inversion list instead if the input parameters allow it.
*
* <invlist> is only valid for binary properties */
+ PMOP *old_PL_curpm= PL_curpm; /* save away the old PL_curpm */
+
SV* retval = &PL_sv_undef;
HV* swash_hv = NULL;
const int invlist_swash_boundary =
assert(listsv != &PL_sv_undef || strNE(name, "") || invlist);
assert(! invlist || minbits == 1);
+ PL_curpm= NULL; /* reset PL_curpm so that we dont get confused between the regex
+ that triggered the swash init and the swash init perl logic itself.
+ See perl #122747 */
+
/* If data was passed in to go out to utf8_heavy to find the swash of, do
* so */
if (listsv != &PL_sv_undef || strNE(name, "")) {
PUSHSTACKi(PERLSI_MAGIC);
ENTER;
SAVEHINTS();
- save_re_context();
/* We might get here via a subroutine signature which uses a utf8
* parameter name, at which point PL_subname will have been set
* but not yet used. */
ENTER;
if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
GvSV(PL_errgv) = NULL;
+#ifndef NO_TAINT_SUPPORT
/* It is assumed that callers of this routine are not passing in
* any user derived data. */
- /* Need to do this after save_re_context() as it will set
- * PL_tainted to 1 while saving $1 etc (see the code after getrx:
- * in Perl_magic_get). Even line to create errsv_save can turn on
- * PL_tainted. */
-#ifndef NO_TAINT_SUPPORT
SAVEBOOL(TAINT_get);
TAINT_NOT;
#endif
/* If caller wants to handle missing properties, let them */
if (flags_p && *flags_p & _CORE_SWASH_INIT_RETURN_IF_UNDEF) {
- return NULL;
+ CORE_SWASH_INIT_RETURN(NULL);
}
Perl_croak(aTHX_
"Can't find Unicode property definition \"%"SVf"\"",
}
}
- return retval;
+ CORE_SWASH_INIT_RETURN(retval);
+#undef CORE_SWASH_INIT_RETURN
}
(ANYOF_NONBITMAP(node)) && \
(ANYOF_FLAGS(node) & ANYOF_LOC_NONBITMAP_FOLD) && \
((end) > (input) + 1) && \
- toFOLD((input)[0]) == 's' && \
- toFOLD((input)[1]) == 's')
+ isALPHA_FOLD_EQ((input)[0], 's'))
#define SHARP_S_SKIP 2
SV *exarg;
ENTER;
- save_re_context();
if (warn) {
SAVESPTR(*hook);
*hook = NULL;
#endif
/*
+=for apidoc quadmath_format_single
+
+quadmath_snprintf() is very strict about its format string and will
+fail, returning -1, if the format is invalid. It acccepts exactly
+one format spec.
+
+quadmath_format_single() checks that the intended single spec looks
+sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
+and has C<Q> before it. This is not a full "printf syntax check",
+just the basics.
+
+Returns the format if it is valid, NULL if not.
+
+quadmath_format_single() can and will actually patch in the missing
+C<Q>, if necessary. In this case it will return the modified copy of
+the format, B<which the caller will need to free.>
+
+See also L</quadmath_format_needed>.
+
+=cut
+*/
+#ifdef USE_QUADMATH
+const char*
+Perl_quadmath_format_single(const char* format)
+{
+ STRLEN len;
+
+ PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE;
+
+ if (format[0] != '%' || strchr(format + 1, '%'))
+ return NULL;
+ len = strlen(format);
+ /* minimum length three: %Qg */
+ if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL)
+ return NULL;
+ if (format[len - 2] != 'Q') {
+ char* fixed;
+ Newx(fixed, len + 1, char);
+ memcpy(fixed, format, len - 1);
+ fixed[len - 1] = 'Q';
+ fixed[len ] = format[len - 1];
+ fixed[len + 1] = 0;
+ return (const char*)fixed;
+ }
+ return format;
+}
+#endif
+
+/*
+=for apidoc quadmath_format_needed
+
+quadmath_format_needed() returns true if the format string seems to
+contain at least one non-Q-prefixed %[efgaEFGA] format specifier,
+or returns false otherwise.
+
+The format specifier detection is not complete printf-syntax detection,
+but it should catch most common cases.
+
+If true is returned, those arguments B<should> in theory be processed
+with quadmath_snprintf(), but in case there is more than one such
+format specifier (see L</quadmath_format_single>), and if there is
+anything else beyond that one (even just a single byte), they
+B<cannot> be processed because quadmath_snprintf() is very strict,
+accepting only one format spec, and nothing else.
+In this case, the code should probably fail.
+
+=cut
+*/
+#ifdef USE_QUADMATH
+bool
+Perl_quadmath_format_needed(const char* format)
+{
+ const char *p = format;
+ const char *q;
+
+ PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED;
+
+ while ((q = strchr(p, '%'))) {
+ q++;
+ if (*q == '+') /* plus */
+ q++;
+ if (*q == '#') /* alt */
+ q++;
+ if (*q == '*') /* width */
+ q++;
+ else {
+ if (isDIGIT(*q)) {
+ while (isDIGIT(*q)) q++;
+ }
+ }
+ if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */
+ q++;
+ if (*q == '*')
+ q++;
+ else
+ while (isDIGIT(*q)) q++;
+ }
+ if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
+ return TRUE;
+ p = q + 1;
+ }
+ return FALSE;
+}
+#endif
+
+/*
=for apidoc my_snprintf
The C library C<snprintf> functionality, if available and
int
Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
{
- int retval;
+ int retval = -1;
va_list ap;
PERL_ARGS_ASSERT_MY_SNPRINTF;
#ifndef HAS_VSNPRINTF
PERL_UNUSED_VAR(len);
#endif
va_start(ap, format);
+#ifdef USE_QUADMATH
+ {
+ const char* qfmt = quadmath_format_single(format);
+ bool quadmath_valid = FALSE;
+ if (qfmt) {
+ /* If the format looked promising, use it as quadmath. */
+ retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
+ if (retval == -1)
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+ quadmath_valid = TRUE;
+ if (qfmt != format)
+ Safefree(qfmt);
+ qfmt = NULL;
+ }
+ assert(qfmt == NULL);
+ /* quadmath_format_single() will return false for example for
+ * "foo = %g", or simply "%g". We could handle the %g by
+ * using quadmath for the NV args. More complex cases of
+ * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise
+ * quadmath-valid but has stuff in front).
+ *
+ * Handling the "Q-less" cases right would require walking
+ * through the va_list and rewriting the format, calling
+ * quadmath for the NVs, building a new va_list, and then
+ * letting vsnprintf/vsprintf to take care of the other
+ * arguments. This may be doable.
+ *
+ * We do not attempt that now. But for paranoia, we here try
+ * to detect some common (but not all) cases where the
+ * "Q-less" %[efgaEFGA] formats are present, and die if
+ * detected. This doesn't fix the problem, but it stops the
+ * vsnprintf/vsprintf pulling doubles off the va_list when
+ * __float128 NVs should be pulled off instead.
+ *
+ * If quadmath_format_needed() returns false, we are reasonably
+ * certain that we can call vnsprintf() or vsprintf() safely. */
+ if (!quadmath_valid && quadmath_format_needed(format))
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
+
+ }
+#endif
+ if (retval == -1)
#ifdef HAS_VSNPRINTF
- retval = vsnprintf(buffer, len, format, ap);
+ retval = vsnprintf(buffer, len, format, ap);
#else
- retval = vsprintf(buffer, format, ap);
+ retval = vsprintf(buffer, format, ap);
#endif
va_end(ap);
/* vsprintf() shows failure with < 0 */
int
Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
{
+#ifdef USE_QUADMATH
+ PERL_UNUSED_ARG(buffer);
+ PERL_UNUSED_ARG(len);
+ PERL_UNUSED_ARG(format);
+ PERL_UNUSED_ARG(ap);
+ Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath");
+ return 0;
+#else
int retval;
#ifdef NEED_VA_COPY
va_list apc;
)
Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
return retval;
+#endif
}
void
if (!PERLDB_SUB_NN) {
GV *gv = CvGV(cv);
- if (!svp) {
+ if (!svp && !CvLEXICAL(cv)) {
gv_efullname3(dbsv, gv, NULL);
}
- else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+ else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv)
|| strEQ(GvNAME(gv), "END")
|| ( /* Could be imported, and old sub redefined. */
(GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
else {
sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
sv_catpvs(dbsv, "::");
- sv_catpvn_flags(
- dbsv, GvNAME(gv), GvNAMELEN(gv),
- GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
- );
+ sv_cathek(dbsv, GvNAME_HEK(gv));
}
}
else {
extra.pods : miniperl
@ @extra_pods.com
-PERLDELTA_CURRENT = [.pod]perl5213delta.pod
+PERLDELTA_CURRENT = [.pod]perl5214delta.pod
$(PERLDELTA_CURRENT) : [.pod]perldelta.pod
Copy/NoConfirm/Log $(MMS$SOURCE) $(PERLDELTA_CURRENT)
#define HINT_V_VMSISH 24
#define HINT_M_VMSISH_STATUS 0x40000000 /* system, $? return VMS status */
#define HINT_M_VMSISH_TIME 0x80000000 /* times are local, not UTC */
-#define NATIVE_HINTS (PL_hints >> HINT_V_VMSISH) /* used in op.c */
+#define NATIVE_HINTS ((PL_hints >> HINT_V_VMSISH) & OPpHINT_M_VMSISH_MASK)
#ifdef PERL_IMPLICIT_CONTEXT
# define TEST_VMSISH(h) (my_perl && PL_curcop && (PL_curcop->op_private & ((h) >> HINT_V_VMSISH)))
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER = \5.21.3
+#INST_VER = \5.21.4
#
# 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\perl5213delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5214delta.pod
cd ..\win32
$(PERLEXE) $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
-if exist $(LIBDIR)\Pod\Text rmdir /s /q $(LIBDIR)\Pod\Text
-if exist $(LIBDIR)\Scalar rmdir /s /q $(LIBDIR)\Scalar
-if exist $(LIBDIR)\Search rmdir /s /q $(LIBDIR)\Search
+ -if exist $(LIBDIR)\Sub rmdir /s /q $(LIBDIR)\Sub
-if exist $(LIBDIR)\Sys rmdir /s /q $(LIBDIR)\Sys
-if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP
-if exist $(LIBDIR)\Term rmdir /s /q $(LIBDIR)\Term
-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 \
- perl5213delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5214delta.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 \
d__fwalk='undef'
d_access='define'
d_accessx='undef'
+d_acosh='undef'
d_aintl='undef'
d_alarm='undef'
d_archlib='define'
d_fd_macros='define'
d_fd_set='define'
d_fds_bits='define'
+d_fegetround='undef'
d_fgetpos='define'
d_finite='undef'
d_finitel='undef'
d_flockproto='undef'
d_fork='undef'
d_fp_class='undef'
+d_fp_classify='undef'
+d_fp_classl='undef'
d_fpathconf='undef'
d_fpclass='undef'
d_fpclassify='undef'
d_fpclassl='undef'
+d_fpgetround='undef'
d_fpos64_t='undef'
d_frexpl='undef'
d_fs_data_s='undef'
d_isascii='define'
d_isblank='undef'
d_isfinite='undef'
+d_isfinitel='undef'
d_isinf='undef'
+d_isinfl='undef'
d_isnan='define'
d_isnanl='undef'
+d_j0='undef'
+d_j0l='undef'
d_killpg='undef'
d_lchown='undef'
d_ldbl_dig='define'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
d_truncate='undef'
+d_truncl='undef'
d_ttyname_r='undef'
d_tzname='define'
d_u32align='undef'
i_dlfcn='define'
i_execinfo='undef'
i_fcntl='define'
+i_fenv='undef'
i_float='define'
i_fp='undef'
i_fp_class='undef'
i_prot='undef'
i_pthread='undef'
i_pwd='undef'
+i_quadmath='undef'
i_rpcsvcdbm='undef'
i_sgtty='undef'
i_shadow='undef'
i_stdarg='define'
i_stdbool='undef'
i_stddef='define'
+i_stdint='undef'
i_stdlib='define'
i_string='define'
i_sunmath='undef'
useopcode='true'
useperlio='~USE_PERLIO~'
useposix='true'
+usequadmath='undef'
usereentrant='undef'
userelocatableinc='undef'
useshrplib='true'
d__fwalk='undef'
d_access='define'
d_accessx='undef'
+d_acosh='undef'
d_aintl='undef'
d_alarm='define'
d_archlib='define'
d_fd_macros='define'
d_fd_set='define'
d_fds_bits='define'
+d_fegetround='undef'
d_fgetpos='define'
d_finite='undef'
d_finitel='undef'
d_flockproto='define'
d_fork='undef'
d_fp_class='undef'
+d_fp_classify='undef'
+d_fp_classl='undef'
d_fpathconf='undef'
d_fpclass='undef'
d_fpclassify='undef'
d_fpclassl='undef'
+d_fpgetround='undef'
d_fpos64_t='undef'
d_frexpl='undef'
d_fs_data_s='undef'
d_isascii='define'
d_isblank='undef'
d_isfinite='undef'
+d_isfinitel='undef'
d_isinf='undef'
+d_isinfl='undef'
d_isnan='define'
d_isnanl='undef'
+d_j0='undef'
+d_j0l='undef'
d_killpg='define'
d_lchown='undef'
d_ldbl_dig='define'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
d_truncate='undef'
+d_truncl='undef'
d_ttyname_r='undef'
d_tzname='define'
d_u32align='define'
i_dlfcn='define'
i_execinfo='undef'
i_fcntl='define'
+i_fenv='undef'
i_float='define'
i_fp='undef'
i_fp_class='undef'
i_prot='undef'
i_pthread='undef'
i_pwd='undef'
+i_quadmath='undef'
i_rpcsvcdbm='undef'
i_sgtty='undef'
i_shadow='undef'
i_stdarg='define'
i_stdbool='define'
i_stddef='define'
+i_stdint='undef'
i_stdlib='define'
i_string='define'
i_sunmath='undef'
useopcode='true'
useperlio='undef'
useposix='true'
+usequadmath='undef'
usereentrant='undef'
userelocatableinc='undef'
useshrplib='true'
d__fwalk='undef'
d_access='define'
d_accessx='undef'
+d_acosh='undef'
d_aintl='undef'
d_alarm='define'
d_archlib='define'
d_fd_macros='define'
d_fd_set='define'
d_fds_bits='define'
+d_fegetround='undef'
d_fgetpos='define'
d_finite='undef'
d_finitel='undef'
d_flockproto='define'
d_fork='undef'
d_fp_class='undef'
+d_fp_classify='undef'
+d_fp_classl='undef'
d_fpathconf='undef'
d_fpclass='undef'
d_fpclassify='undef'
d_fpclassl='undef'
+d_fpgetround='undef'
d_fpos64_t='undef'
d_frexpl='undef'
d_fs_data_s='undef'
d_isascii='define'
d_isblank='undef'
d_isfinite='undef'
+d_isfinitel='undef'
d_isinf='undef'
+d_isinfl='undef'
d_isnan='define'
d_isnanl='undef'
+d_j0='undef'
+d_j0l='undef'
d_killpg='define'
d_lchown='undef'
d_ldbl_dig='define'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
d_truncate='undef'
+d_truncl='undef'
d_ttyname_r='undef'
d_tzname='define'
d_u32align='define'
i_dlfcn='define'
i_execinfo='undef'
i_fcntl='define'
+i_fenv='undef'
i_float='define'
i_fp='undef'
i_fp_class='undef'
i_prot='undef'
i_pthread='undef'
i_pwd='undef'
+i_quadmath='undef'
i_rpcsvcdbm='undef'
i_sgtty='undef'
i_shadow='undef'
i_stdarg='define'
i_stdbool='undef'
i_stddef='define'
+i_stdint='undef'
i_stdlib='define'
i_string='define'
i_sunmath='undef'
useopcode='true'
useperlio='undef'
useposix='true'
+usequadmath='undef'
usereentrant='undef'
userelocatableinc='undef'
useshrplib='true'
/* Package name : perl5
* Source directory :
- * Configuration time: Wed Sep 18 14:03:46 2013
+ * Configuration time: Wed Sep 17 14:09:08 2014
* Configured by : shay
* Target system :
*/
/* HAS_MBSTOWCS:
* This symbol, if defined, indicates that the mbstowcs routine is
- * available to covert a multibyte string into a wide character string.
+ * available to convert a multibyte string into a wide character string.
*/
#define HAS_MBSTOWCS /**/
/* HAS_MBTOWC:
* This symbol, if defined, indicates that the mbtowc routine is available
- * to covert a multibyte to a wide character.
+ * to convert a multibyte to a wide character.
*/
#define HAS_MBTOWC /**/
/* HAS_WCTOMB:
* This symbol, if defined, indicates that the wctomb routine is available
- * to covert a wide character to a multibyte.
+ * to convert a wide character to a multibyte.
*/
#define HAS_WCTOMB /**/
*/
/*#define I_SYS_WAIT / **/
-/* 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_UNISTD:
* This symbol, if defined, indicates to the C program that it should
* include <unistd.h>.
*/
/*#define MULTIARCH / **/
-/* USE_CROSS_COMPILE:
- * This symbol, if defined, indicates that Perl is being cross-compiled.
- */
-/* PERL_TARGETARCH:
- * This symbol, if defined, indicates the target architecture
- * Perl has been cross-compiled to. Undefined if not a cross-compile.
- */
-#ifndef USE_CROSS_COMPILE
-/*#define USE_CROSS_COMPILE / **/
-#define PERL_TARGETARCH "" /**/
-#endif
-
/* MEM_ALIGNBYTES:
* This symbol contains the number of bytes required to align a
* double, or a long double when applicable. Usual values are 2,
* This symbol holds the hexadecimal constant defined in byteorder,
* in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc...
* If the compiler supports cross-compiling or multiple-architecture
- * binaries (e.g. on NeXT systems), use compiler-defined macros to
+ * binaries, use compiler-defined macros to
* determine the byte order.
- * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture
- * Binaries (MAB) on either big endian or little endian machines.
- * The endian-ness is available at compile-time. This only matters
- * for perl, where the config.h can be generated and installed on
- * one system, and used by a different architecture to build an
- * extension. Older versions of NeXT that might not have
- * defined either *_ENDIAN__ were all on Motorola 680x0 series,
- * so the default case (for NeXT) is big endian to catch them.
- * This might matter for NeXT 3.0.
*/
#if defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# endif
# endif
# endif
-# if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__))
-# define BYTEORDER 0x4321
-# endif
#else
#define BYTEORDER 0x1234 /* large digits for MSB */
-#endif /* NeXT */
+#endif
/* CHARBITS:
* This symbol contains the size of a char, so that the C preprocessor
/*#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.
* C preprocessor can make decisions based on it. It is only
* defined if the system supports long doubles.
*/
+/* HAS_LDEXPL:
+ * This symbol, if defined, indicates that the ldexpl routine is
+ * available to shift a long double floating-point number
+ * by an integral power of 2.
+ */
+/* LONG_DOUBLEKIND:
+ * LONG_DOUBLEKIND will be one of
+ * LONG_DOUBLE_IS_DOUBLE
+ * LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
+ * LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN
+ * LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
+ * LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
+ * LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN
+ * LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
+ * LONG_DOUBLE_IS_UNKNOWN_FORMAT
+ * It is only defined if the system supports long doubles.
+ */
+/*#define HAS_LDEXPL / **/
#define HAS_LONG_DOUBLE /**/
#ifdef HAS_LONG_DOUBLE
#define LONG_DOUBLESIZE 12 /**/
+#define LONG_DOUBLEKIND 3 /**/
+#define LONG_DOUBLE_IS_DOUBLE 0
+#define LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN 1
+#define LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN 2
+#define LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN 3
+#define LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN 4
+#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN 5
+#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN 6
+#define LONG_DOUBLE_IS_UNKNOWN_FORMAT -1
#endif
/* HAS_LONG_LONG:
* This symbol, if defined, indicates that this system uses
* EBCDIC encoding.
*/
-/* BOOTSTRAP_CHARSET:
- * This symbol, if defined, indicates that this system needs
- * converting various files to the native character set before
- * bringing up perl on a system that has a non-ASCII character
- * set and no working perl.
- */
/*#define EBCDIC / **/
-/*#define BOOTSTRAP_CHARSET / **/
/* Fpos_t:
* This symbol holds the type used to declare file positions in libc.
#define DIRNAMLEN /**/
#define Direntry_t struct direct
+/* 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 "" / **/
+/* USE_CROSS_COMPILE:
+ * This symbol, if defined, indicates that Perl is being cross-compiled.
+ */
+/* PERL_TARGETARCH:
+ * This symbol, if defined, indicates the target architecture
+ * Perl has been cross-compiled to. Undefined if not a cross-compile.
+ */
+#ifndef USE_CROSS_COMPILE
+/*#define USE_CROSS_COMPILE / **/
+#define PERL_TARGETARCH "" /**/
+#endif
+
/* PERL_USE_DEVEL:
* This symbol, if defined, indicates that Perl was configured with
* -Dusedevel, to enable development features. This should not be
*/
/*#define HAS__FWALK / **/
+/* HAS_ACOSH:
+ * This symbol, if defined, indicates that the acosh routine is
+ * available to do the inverse hyperbolic cosine function.
+ */
+/*#define HAS_ACOSH / **/
+
/* HAS_AINTL:
* This symbol, if defined, indicates that the aintl routine is
* available. If copysignl is also present we can emulate modfl.
*/
/*#define FCNTL_CAN_LOCK / **/
+/* HAS_FEGETROUND:
+ * This symbol, if defined, indicates that the fegetround routine is
+ * available to return the macro corresponding to the current rounding
+ * mode.
+ */
+/*#define HAS_FEGETROUND / **/
+
/* HAS_FINITE:
* This symbol, if defined, indicates that the finite routine is
* available to check whether a double is finite (non-infinity non-NaN).
*/
/*#define HAS_FP_CLASS / **/
+/* HAS_FP_CLASSL:
+ * This symbol, if defined, indicates that the fp_classl routine is
+ * available to classify long doubles. Available for example in
+ * Digital UNIX. See for possible values HAS_FP_CLASS.
+ */
+/*#define HAS_FP_CLASSL / **/
+
/* HAS_FPCLASS:
* This symbol, if defined, indicates that the fpclass routine is
* available to classify doubles. Available for example in Solaris/SVR4.
* FP_NAN NaN
*
*/
-/*#define HAS_FPCLASSIFY / **/
+/* HAS_FP_CLASSIFY:
+ * This symbol, if defined, indicates that the fp_classify routine is
+ * available to classify doubles. The values are defined in <math.h>
+ *
+ * FP_NORMAL Normalized
+ * FP_ZERO Zero
+ * FP_INFINITE Infinity
+ * FP_SUBNORMAL Denormalized
+ * FP_NAN NaN
+ *
+ */
+/*#define HAS_FPCLASSIFY / **/
+/*#define HAS_FP_CLASSIFY / **/
/* HAS_FPCLASSL:
* This symbol, if defined, indicates that the fpclassl routine is
*/
/*#define HAS_FPCLASSL / **/
+/* HAS_FPGETROUND:
+ * This symbol, if defined, indicates that the fpgetround routine is
+ * available to get the floating point rounding mode.
+ */
+/*#define HAS_FPGETROUND / **/
+
/* HAS_FPOS64_T:
* This symbol will be defined if the C compiler supports fpos64_t.
*/
*/
/*#define HAS_ISFINITE / **/
+/* HAS_ISFINITEL:
+ * This symbol, if defined, indicates that the isfinitel routine is
+ * available to check whether a long double is finite.
+ * (non-infinity non-NaN).
+ */
+/*#define HAS_ISFINITEL / **/
+
/* HAS_ISINF:
* This symbol, if defined, indicates that the isinf routine is
* available to check whether a double is an infinity.
*/
/*#define HAS_ISINF / **/
+/* HAS_ISINFL:
+ * This symbol, if defined, indicates that the isinfl routine is
+ * available to check whether a long double is an infinity.
+ */
+/*#define HAS_ISINFL / **/
+
/* HAS_ISNAN:
* This symbol, if defined, indicates that the isnan routine is
* available to check whether a double is a NaN.
*/
/*#define HAS_ISNANL / **/
+/* HAS_J0:
+ * This symbol, if defined, indicates to the C program that the
+ * j0() function is available for Bessel functions of the first
+ * kind of the order zero, for doubles.
+ */
+/* HAS_J0L:
+ * This symbol, if defined, indicates to the C program that the
+ * j0l() function is available for Bessel functions of the first
+ * kind of the order zero, for long doubles.
+ */
+/*#define HAS_J0 / **/
+/*#define HAS_J0L / **/
+
/* HAS_LDBL_DIG:
* This symbol, if defined, indicates that this system's <float.h>
* or <limits.h> defines the symbol LDBL_DIG, which is the number
*/
/*#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>
*/
/*#define HAS_TIMEGM / **/
+/* HAS_TRUNCL:
+ * This symbol, if defined, indicates that the truncl routine is
+ * available. If copysignl is also present we can emulate modfl.
+ */
+/*#define HAS_TRUNCL / **/
+
/* U32_ALIGNMENT_REQUIRED:
* This symbol, if defined, indicates that you must access
* character data through U32-aligned pointers.
*/
/*#define HAS_USTAT / **/
+/* HAS_WCSCMP:
+ * This symbol, if defined, indicates that the wcscmp routine is
+ * available to compare two wide character strings.
+ */
+#define HAS_WCSCMP /**/
+
+/* HAS_WCSXFRM:
+ * This symbol, if defined, indicates that the wcsxfrm routine is
+ * available to tranform a wide character string for wcscmp().
+ */
+#define HAS_WCSXFRM /**/
+
/* HAS_WRITEV:
* This symbol, if defined, indicates that the writev routine is
* available to do scatter writes.
*/
#define I_ASSERT /**/
+/* I_BFD:
+ * This symbol, if defined, indicates that <bfd.h> exists and
+ * can be included.
+ */
+/*#define I_BFD / **/
+
/* I_CRYPT:
* This symbol, if defined, indicates that <crypt.h> exists and
* should be included.
#define DB_VERSION_MINOR_CFG 0 /**/
#define DB_VERSION_PATCH_CFG 0 /**/
+/* I_FENV:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <fenv.h> to get the floating point environment definitions.
+ */
+/*#define I_FENV / **/
+
/* I_FP:
* This symbol, if defined, indicates that <fp.h> exists and
* should be included.
*/
#define I_STDBOOL /**/
+/* I_STDINT:
+ * This symbol, if defined, indicates that <stdint.h> exists and
+ * should be included.
+ */
+/*#define I_STDINT / **/
+
/* I_SUNMATH:
* This symbol, if defined, indicates that <sunmath.h> exists and
* should be included.
/*#define USE_64_BIT_ALL / **/
#endif
+/* USE_CBACKTRACE:
+ * This symbol, if defined, indicates that Perl should
+ * be built with support for backtrace.
+ */
+/*#define USE_CBACKTRACE / **/
+
/* USE_DTRACE:
* This symbol, if defined, indicates that Perl should
* be built with support for DTrace.
/* Package name : perl5
* Source directory :
- * Configuration time: Wed Sep 18 13:50:58 2013
+ * Configuration time: Wed Sep 17 13:53:56 2014
* Configured by : shay
* Target system :
*/
/* HAS_MBSTOWCS:
* This symbol, if defined, indicates that the mbstowcs routine is
- * available to covert a multibyte string into a wide character string.
+ * available to convert a multibyte string into a wide character string.
*/
#define HAS_MBSTOWCS /**/
/* HAS_MBTOWC:
* This symbol, if defined, indicates that the mbtowc routine is available
- * to covert a multibyte to a wide character.
+ * to convert a multibyte to a wide character.
*/
#define HAS_MBTOWC /**/
/* HAS_WCTOMB:
* This symbol, if defined, indicates that the wctomb routine is available
- * to covert a wide character to a multibyte.
+ * to convert a wide character to a multibyte.
*/
#define HAS_WCTOMB /**/
*/
/*#define I_SYS_WAIT / **/
-/* 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_UNISTD:
* This symbol, if defined, indicates to the C program that it should
* include <unistd.h>.
*/
/*#define MULTIARCH / **/
-/* USE_CROSS_COMPILE:
- * This symbol, if defined, indicates that Perl is being cross-compiled.
- */
-/* PERL_TARGETARCH:
- * This symbol, if defined, indicates the target architecture
- * Perl has been cross-compiled to. Undefined if not a cross-compile.
- */
-#ifndef USE_CROSS_COMPILE
-/*#define USE_CROSS_COMPILE / **/
-#define PERL_TARGETARCH "" /**/
-#endif
-
/* MEM_ALIGNBYTES:
* This symbol contains the number of bytes required to align a
* double, or a long double when applicable. Usual values are 2,
* This symbol holds the hexadecimal constant defined in byteorder,
* in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc...
* If the compiler supports cross-compiling or multiple-architecture
- * binaries (e.g. on NeXT systems), use compiler-defined macros to
+ * binaries, use compiler-defined macros to
* determine the byte order.
- * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture
- * Binaries (MAB) on either big endian or little endian machines.
- * The endian-ness is available at compile-time. This only matters
- * for perl, where the config.h can be generated and installed on
- * one system, and used by a different architecture to build an
- * extension. Older versions of NeXT that might not have
- * defined either *_ENDIAN__ were all on Motorola 680x0 series,
- * so the default case (for NeXT) is big endian to catch them.
- * This might matter for NeXT 3.0.
*/
#if defined(MULTIARCH)
# ifdef __LITTLE_ENDIAN__
# endif
# endif
# endif
-# if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__))
-# define BYTEORDER 0x4321
-# endif
#else
#define BYTEORDER 0x1234 /* large digits for MSB */
-#endif /* NeXT */
+#endif
/* CHARBITS:
* This symbol contains the size of a char, so that the C preprocessor
/*#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.
* C preprocessor can make decisions based on it. It is only
* defined if the system supports long doubles.
*/
+/* HAS_LDEXPL:
+ * This symbol, if defined, indicates that the ldexpl routine is
+ * available to shift a long double floating-point number
+ * by an integral power of 2.
+ */
+/* LONG_DOUBLEKIND:
+ * LONG_DOUBLEKIND will be one of
+ * LONG_DOUBLE_IS_DOUBLE
+ * LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
+ * LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN
+ * LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
+ * LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
+ * LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN
+ * LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
+ * LONG_DOUBLE_IS_UNKNOWN_FORMAT
+ * It is only defined if the system supports long doubles.
+ */
+/*#define HAS_LDEXPL / **/
#define HAS_LONG_DOUBLE /**/
#ifdef HAS_LONG_DOUBLE
#define LONG_DOUBLESIZE 8 /**/
+#define LONG_DOUBLEKIND 0 /**/
+#define LONG_DOUBLE_IS_DOUBLE 0
+#define LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN 1
+#define LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN 2
+#define LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN 3
+#define LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN 4
+#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN 5
+#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN 6
+#define LONG_DOUBLE_IS_UNKNOWN_FORMAT -1
#endif
/* HAS_LONG_LONG:
* This symbol, if defined, indicates that this system uses
* EBCDIC encoding.
*/
-/* BOOTSTRAP_CHARSET:
- * This symbol, if defined, indicates that this system needs
- * converting various files to the native character set before
- * bringing up perl on a system that has a non-ASCII character
- * set and no working perl.
- */
/*#define EBCDIC / **/
-/*#define BOOTSTRAP_CHARSET / **/
/* Fpos_t:
* This symbol holds the type used to declare file positions in libc.
#define DIRNAMLEN /**/
#define Direntry_t struct direct
+/* 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 "" / **/
+/* USE_CROSS_COMPILE:
+ * This symbol, if defined, indicates that Perl is being cross-compiled.
+ */
+/* PERL_TARGETARCH:
+ * This symbol, if defined, indicates the target architecture
+ * Perl has been cross-compiled to. Undefined if not a cross-compile.
+ */
+#ifndef USE_CROSS_COMPILE
+/*#define USE_CROSS_COMPILE / **/
+#define PERL_TARGETARCH "" /**/
+#endif
+
/* PERL_USE_DEVEL:
* This symbol, if defined, indicates that Perl was configured with
* -Dusedevel, to enable development features. This should not be
*/
/*#define HAS__FWALK / **/
+/* HAS_ACOSH:
+ * This symbol, if defined, indicates that the acosh routine is
+ * available to do the inverse hyperbolic cosine function.
+ */
+/*#define HAS_ACOSH / **/
+
/* HAS_AINTL:
* This symbol, if defined, indicates that the aintl routine is
* available. If copysignl is also present we can emulate modfl.
*/
/*#define FCNTL_CAN_LOCK / **/
+/* HAS_FEGETROUND:
+ * This symbol, if defined, indicates that the fegetround routine is
+ * available to return the macro corresponding to the current rounding
+ * mode.
+ */
+/*#define HAS_FEGETROUND / **/
+
/* HAS_FINITE:
* This symbol, if defined, indicates that the finite routine is
* available to check whether a double is finite (non-infinity non-NaN).
*/
/*#define HAS_FP_CLASS / **/
+/* HAS_FP_CLASSL:
+ * This symbol, if defined, indicates that the fp_classl routine is
+ * available to classify long doubles. Available for example in
+ * Digital UNIX. See for possible values HAS_FP_CLASS.
+ */
+/*#define HAS_FP_CLASSL / **/
+
/* HAS_FPCLASS:
* This symbol, if defined, indicates that the fpclass routine is
* available to classify doubles. Available for example in Solaris/SVR4.
* FP_NAN NaN
*
*/
-/*#define HAS_FPCLASSIFY / **/
+/* HAS_FP_CLASSIFY:
+ * This symbol, if defined, indicates that the fp_classify routine is
+ * available to classify doubles. The values are defined in <math.h>
+ *
+ * FP_NORMAL Normalized
+ * FP_ZERO Zero
+ * FP_INFINITE Infinity
+ * FP_SUBNORMAL Denormalized
+ * FP_NAN NaN
+ *
+ */
+/*#define HAS_FPCLASSIFY / **/
+/*#define HAS_FP_CLASSIFY / **/
/* HAS_FPCLASSL:
* This symbol, if defined, indicates that the fpclassl routine is
*/
/*#define HAS_FPCLASSL / **/
+/* HAS_FPGETROUND:
+ * This symbol, if defined, indicates that the fpgetround routine is
+ * available to get the floating point rounding mode.
+ */
+/*#define HAS_FPGETROUND / **/
+
/* HAS_FPOS64_T:
* This symbol will be defined if the C compiler supports fpos64_t.
*/
*/
/*#define HAS_ISFINITE / **/
+/* HAS_ISFINITEL:
+ * This symbol, if defined, indicates that the isfinitel routine is
+ * available to check whether a long double is finite.
+ * (non-infinity non-NaN).
+ */
+/*#define HAS_ISFINITEL / **/
+
/* HAS_ISINF:
* This symbol, if defined, indicates that the isinf routine is
* available to check whether a double is an infinity.
*/
/*#define HAS_ISINF / **/
+/* HAS_ISINFL:
+ * This symbol, if defined, indicates that the isinfl routine is
+ * available to check whether a long double is an infinity.
+ */
+/*#define HAS_ISINFL / **/
+
/* HAS_ISNAN:
* This symbol, if defined, indicates that the isnan routine is
* available to check whether a double is a NaN.
*/
/*#define HAS_ISNANL / **/
+/* HAS_J0:
+ * This symbol, if defined, indicates to the C program that the
+ * j0() function is available for Bessel functions of the first
+ * kind of the order zero, for doubles.
+ */
+/* HAS_J0L:
+ * This symbol, if defined, indicates to the C program that the
+ * j0l() function is available for Bessel functions of the first
+ * kind of the order zero, for long doubles.
+ */
+/*#define HAS_J0 / **/
+/*#define HAS_J0L / **/
+
/* HAS_LDBL_DIG:
* This symbol, if defined, indicates that this system's <float.h>
* or <limits.h> defines the symbol LDBL_DIG, which is the number
*/
/*#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>
*/
/*#define HAS_TIMEGM / **/
+/* HAS_TRUNCL:
+ * This symbol, if defined, indicates that the truncl routine is
+ * available. If copysignl is also present we can emulate modfl.
+ */
+/*#define HAS_TRUNCL / **/
+
/* U32_ALIGNMENT_REQUIRED:
* This symbol, if defined, indicates that you must access
* character data through U32-aligned pointers.
*/
/*#define HAS_USTAT / **/
+/* HAS_WCSCMP:
+ * This symbol, if defined, indicates that the wcscmp routine is
+ * available to compare two wide character strings.
+ */
+#define HAS_WCSCMP /**/
+
+/* HAS_WCSXFRM:
+ * This symbol, if defined, indicates that the wcsxfrm routine is
+ * available to tranform a wide character string for wcscmp().
+ */
+#define HAS_WCSXFRM /**/
+
/* HAS_WRITEV:
* This symbol, if defined, indicates that the writev routine is
* available to do scatter writes.
*/
#define I_ASSERT /**/
+/* I_BFD:
+ * This symbol, if defined, indicates that <bfd.h> exists and
+ * can be included.
+ */
+/*#define I_BFD / **/
+
/* I_CRYPT:
* This symbol, if defined, indicates that <crypt.h> exists and
* should be included.
#define DB_VERSION_MINOR_CFG 0 /**/
#define DB_VERSION_PATCH_CFG 0 /**/
+/* I_FENV:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <fenv.h> to get the floating point environment definitions.
+ */
+/*#define I_FENV / **/
+
/* I_FP:
* This symbol, if defined, indicates that <fp.h> exists and
* should be included.
*/
/*#define I_STDBOOL / **/
+/* I_STDINT:
+ * This symbol, if defined, indicates that <stdint.h> exists and
+ * should be included.
+ */
+/*#define I_STDINT / **/
+
/* I_SUNMATH:
* This symbol, if defined, indicates that <sunmath.h> exists and
* should be included.
/*#define USE_64_BIT_ALL / **/
#endif
+/* USE_CBACKTRACE:
+ * This symbol, if defined, indicates that Perl should
+ * be built with support for backtrace.
+ */
+/*#define USE_CBACKTRACE / **/
+
/* USE_DTRACE:
* This symbol, if defined, indicates that Perl should
* be built with support for DTrace.
$opt{libpth} = mungepath($opt{libpth}) if exists $opt{libpth};
$opt{incpath} = mungepath($opt{incpath}) if exists $opt{incpath};
-my($int64, $int64f);
+my $int64;
if ($opt{cc} =~ /\b(?:cl|icl)/) {
$int64 = '__int64';
- $int64f = 'I64';
}
elsif ($opt{cc} =~ /\bgcc\b/) {
$int64 = 'long long';
- $int64f = 'I64';
}
# set large files options
}
if ($opt{use64bitint} eq 'define') {
$opt{d_nv_preserves_uv} = 'undef';
- $opt{ivdformat} = qq{"${int64f}d"};
+ $opt{ivdformat} = qq{"I64d"};
$opt{ivsize} = 8;
$opt{ivtype} = $int64;
$opt{nv_preserves_uv_bits} = 53;
- $opt{sPRIXU64} = qq{"${int64f}X"};
- $opt{sPRId64} = qq{"${int64f}d"};
- $opt{sPRIi64} = qq{"${int64f}i"};
- $opt{sPRIo64} = qq{"${int64f}o"};
- $opt{sPRIu64} = qq{"${int64f}u"};
- $opt{sPRIx64} = qq{"${int64f}x"};
- $opt{uvXUformat} = qq{"${int64f}X"};
- $opt{uvoformat} = qq{"${int64f}o"};
+ $opt{sPRIXU64} = qq{"I64X"};
+ $opt{sPRId64} = qq{"I64d"};
+ $opt{sPRIi64} = qq{"I64i"};
+ $opt{sPRIo64} = qq{"I64o"};
+ $opt{sPRIu64} = qq{"I64u"};
+ $opt{sPRIx64} = qq{"I64x"};
+ $opt{uvXUformat} = qq{"I64X"};
+ $opt{uvoformat} = qq{"I64o"};
$opt{uvsize} = 8;
$opt{uvtype} = qq{unsigned $int64};
- $opt{uvuformat} = qq{"${int64f}u"};
- $opt{uvxformat} = qq{"${int64f}x"};
+ $opt{uvuformat} = qq{"I64u"};
+ $opt{uvxformat} = qq{"I64x"};
}
else {
$opt{d_nv_preserves_uv} = 'define';
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER *= \5.21.3
+#INST_VER *= \5.21.4
#
# Comment this out if you DON'T want your perl installation to have
PERLIMPLIB = ..\libperl521$(a)
PERLSTATICLIB = ..\libperl521s$(a)
INT64 = long long
-INT64f = ll
.ELSE
CFGSH_TMPL = config.vc
CFGH_TMPL = config_H.vc
INT64 = __int64
-INT64f = I64
.ENDIF
@echo #define UVSIZE ^8>>$@
@echo #undef NV_PRESERVES_UV>>$@
@echo #define NV_PRESERVES_UV_BITS 53>>$@
- @echo #define IVdf "$(INT64f)d">>$@
- @echo #define UVuf "$(INT64f)u">>$@
- @echo #define UVof "$(INT64f)o">>$@
- @echo #define UVxf "$(INT64f)x">>$@
- @echo #define UVXf "$(INT64f)X">>$@
+ @echo #define IVdf "I64d">>$@
+ @echo #define UVuf "I64u">>$@
+ @echo #define UVof "I64o">>$@
+ @echo #define UVxf "I64x">>$@
+ @echo #define UVXf "I64X">>$@
@echo #define USE_64_BIT_INT>>$@
.ELSE
@echo #define IVTYPE long>>$@
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5213delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5214delta.pod
$(PERLEXE) $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
$(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q ..
-if exist $(LIBDIR)\Pod\Text rmdir /s /q $(LIBDIR)\Pod\Text
-if exist $(LIBDIR)\Scalar rmdir /s /q $(LIBDIR)\Scalar
-if exist $(LIBDIR)\Search rmdir /s /q $(LIBDIR)\Search
+ -if exist $(LIBDIR)\Sub rmdir /s /q $(LIBDIR)\Sub
-if exist $(LIBDIR)\Sys rmdir /s /q $(LIBDIR)\Sys
-if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP
-if exist $(LIBDIR)\Term rmdir /s /q $(LIBDIR)\Term
-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 \
- perl5213delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5214delta.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 \
perl5181delta.pod \
perl5182delta.pod \
perl5200delta.pod \
+ perl5201delta.pod \
perl5210delta.pod \
perl5211delta.pod \
perl5212delta.pod \
perl5213delta.pod \
+ perl5214delta.pod \
perl561delta.pod \
perl56delta.pod \
perl581delta.pod \
perl5181delta.man \
perl5182delta.man \
perl5200delta.man \
+ perl5201delta.man \
perl5210delta.man \
perl5211delta.man \
perl5212delta.man \
perl5213delta.man \
+ perl5214delta.man \
perl561delta.man \
perl56delta.man \
perl581delta.man \
perl5181delta.html \
perl5182delta.html \
perl5200delta.html \
+ perl5201delta.html \
perl5210delta.html \
perl5211delta.html \
perl5212delta.html \
perl5213delta.html \
+ perl5214delta.html \
perl561delta.html \
perl56delta.html \
perl581delta.html \
perl5181delta.tex \
perl5182delta.tex \
perl5200delta.tex \
+ perl5201delta.tex \
perl5210delta.tex \
perl5211delta.tex \
perl5212delta.tex \
perl5213delta.tex \
+ perl5214delta.tex \
perl561delta.tex \
perl56delta.tex \
perl581delta.tex \
projects / platform / upstream / perl.git / commitdiff