Gideon Israel Dsouza <gideon@cpan.org>
Giles Lean <giles@nemeton.com.au>
Gisle Aas <gisle@aas.no>
+Glenn D. Golden <gdg@zplane.com>
Glenn Linderman <perl@nevcal.com>
Gordon Lack <gml4410@ggr.co.uk>
Gordon J. Miller <gjm@cray.com>
Johan Holtman
Johan Vromans <jvromans@squirrel.nl>
Johann Klasek <jk@auto.tuwien.ac.at>
+Johann 'Myrkraverk' Oskarsson <johann@myrkraverk.com>
Johannes Plunien <plu@pqpq.de>
John Bley <jbb6@acpub.duke.edu>
John Borwick <jhborwic@unity.ncsu.edu>
Wolfram Humann <w.c.humann@arcor.de>
Xavier Noria <fxn@hashref.com>
YAMASHINA Hio <hio@ymir.co.jp>
+Yaroslav Kuzmin <ykuzmin@rocketsoftware.com>
Yary Hluchan
Yasushi Nakajima <sey@jkc.co.jp>
Yitzchak Scott-Thoennes <sthoenna@efn.org>
d_access=''
d_accessx=''
d_acosh=''
+d_asinh=''
+d_atanh=''
d_aintl=''
d_alarm=''
asctime_r_proto=''
d_casti32=''
castflags=''
d_castneg=''
+d_cbrt=''
d_chown=''
d_chroot=''
d_chsize=''
d_void_closedir=''
d_cmsghdr_s=''
d_const=''
+d_copysign=''
d_copysignl=''
d_cplusplus=''
cryptlib=''
d_endsent=''
d_endservent_r=''
endservent_r_proto=''
+d_erf=''
+d_erfc=''
+d_exp2=''
+d_expm1=''
d_faststdio=''
d_fchdir=''
d_fchmod=''
d_fchown=''
d_fcntl=''
d_fcntl_can_lock=''
+d_fdim=''
d_fd_macros=''
d_fd_set=''
d_fds_bits=''
d_flexfnam=''
d_flock=''
d_flockproto=''
+d_fdim=''
+d_fma=''
+d_fmax=''
+d_fmin=''
d_fork=''
d_fp_class=''
d_fp_classl=''
gnulibc_version=''
d_hasmntopt=''
d_htonl=''
+d_hypot=''
+d_ilogb=''
d_ilogbl=''
d_inetaton=''
d_inetntop=''
d_isinfl=''
d_isnan=''
d_isnanl=''
+d_isnormal=''
d_j0=''
d_j0l=''
d_killpg=''
d_lchown=''
d_ldbl_dig=''
+d_lgamma=''
+d_lgamma_r=''
d_libm_lib_version=''
d_link=''
+d_llrint=''
+d_llround=''
d_localtime_r=''
d_localtime_r_needs_tzset=''
localtime_r_proto=''
d_lc_monetary_2008=''
d_lockf=''
d_ldexpl=''
+d_log1p=''
+d_log2=''
+d_logb=''
d_longdbl=''
longdblkind=''
longdblsize=''
d_longlong=''
longlongsize=''
+d_lrint=''
+d_lround=''
d_lseekproto=''
d_lstat=''
d_madvise=''
d_msgsnd=''
d_msync=''
d_munmap=''
+d_nan=''
+d_nearbyint=''
+d_nextafter=''
+d_nexttoward=''
d_nice=''
d_nl_langinfo=''
d_off64_t=''
d_readlink=''
d_readv=''
d_recvmsg=''
+d_remainder=''
+d_remquo=''
d_rename=''
+d_rint=''
d_rmdir=''
+d_round=''
d_safebcpy=''
d_safemcpy=''
d_sanemcmp=''
d_sbrkproto=''
+d_scalbn=''
d_scalbnl=''
d_select=''
d_sem=''
d_times=''
d_tmpnam_r=''
tmpnam_r_proto=''
+d_tgamma=''
+d_trunc=''
d_truncate=''
d_truncl=''
d_ttyname_r=''
ld_can_script=''
lddlflags=''
usedl=''
+doublekind=''
doublesize=''
ebcdic=''
fflushNULL=''
*) case "$lns:$issymlink" in
*"ln"*" -s:"*"test -"?)
echo "Creating the symbolic links..." >&4
- echo "(First creating the subdirectories...)" >&4
cd ..
- awk '{print $1}' $src/MANIFEST | grep / | sed 's:/[^/]*$::' | sort -u | while true; do
- read directory
- test -z "$directory" && break
- mkdir -p $directory
- done
+ awk '{print $1}' $src/MANIFEST | sed -e 's:/\([^/]*\)$: \1:' |
+ awk 'NF == 1 {
+ dir=".";
+ file=$1 "";
+ }
+ NF == 2 {
+ dir=$1 "";
+ file=$2 "";
+ }
+ {
+ print "# dir = ", dir, "file = ", file
+ mf[dir] = mf[dir]" "src"/"dir"/"file;
+ } END {
+ for (d in mf) {
+ if (d != ".") { print("mkdir -p "d) }
+ print("ln -sf "mf[d]" "d);
+ }
+ }' src="$src" > UU/mksymlinks.$$
+ sh UU/mksymlinks.$$
+ rm UU/mksymlinks.$$
# Sanity check 1.
if test ! -d t/base; then
echo "Failed to create the subdirectories. Aborting." >&4
exit 1
fi
- echo "(Then creating the symlinks...)" >&4
- awk '{print $1}' $src/MANIFEST | while true; do
- read filename
- test -z "$filename" && break
- if test -f $filename; then
- if $issymlink $filename; then
- rm -f $filename
- fi
- fi
- if test -f $filename; then
- echo "$filename already exists, not symlinking."
- else
- ln -s $src/$filename $filename
- fi
- done
# Sanity check 2.
if test ! -f t/base/lex.t; then
echo "Failed to create the symlinks (t/base/lex.t missing). Aborting." >&4
exit 1
fi
+ if test ! -f win32/win32.c; then
+ echo "Failed to create the symlinks (win32/win32.c missing). Aborting." >&4
+ exit 1
+ fi
cd UU
;;
*) echo "(I cannot figure out how to do symbolic links, ignoring mksymlinks)." >&4
case "$usequadmath" in
"$define"|true|[yY]*)
usequadmath="$define"
- # if usequadmath enabled also enable uselongdouble
- uselongdouble="$define"
;;
*) usequadmath="$undef" ;;
esac
set float.h i_float
eval $inhdr
+echo " "
+$echo "Checking the kind of doubles you have..." >&4
+$cat <<EOP >try.c
+#$i_stdlib I_STDLIB
+#define DOUBLESIZE $doublesize
+#ifdef I_STDLIB
+#include <stdlib.h>
+#endif
+#include <stdio.h>
+static const double d = -0.1;
+int main() {
+ unsigned const char* b = (unsigned const char*)(&d);
+#if DOUBLESIZE == 4
+ if (b[0] == 0xCD && b[3] == 0xBD) {
+ /* IEEE 754 32-bit little-endian */
+ printf("1\n");
+ exit(0);
+ }
+ if (b[0] == 0xBD && b[3] == 0xCD) {
+ /* IEEE 754 32-bit big-endian */
+ printf("2\n");
+ exit(0);
+ }
+#endif
+#if DOUBLESIZE == 8
+ if (b[0] == 0x9A && b[7] == 0xBF) {
+ /* IEEE 754 64-bit little-endian */
+ printf("3\n");
+ exit(0);
+ }
+ if (b[0] == 0xBF && b[7] == 0x9A) {
+ /* IEEE 754 64-bit big-endian */
+ printf("4\n");
+ exit(0);
+ }
+ if (b[0] == 0x99 && b[3] == 0xBF && b[4] == 0x9A && b[7] == 0x99) {
+ /* ARM mixed endian: two little-endian 32-bit floats, in big endian order:
+ * 4 5 6 7 0 1 2 3 (MSB = 7, LSB = 0)
+ * 99 99 b9 bf 9a 99 99 99 */
+ printf("7\n");
+ exit(0);
+ }
+ if (b[0] == 0x99 && b[3] == 0x9A && b[4] == 0xBF && b[7] == 0x99) {
+ /* The opposite of case 7, mixed endian: two big-endian 32-bit floats,
+ * in little endian order: 3 2 1 0 7 6 5 4 (MSB = 7, LSB = 0)
+ * 99 99 99 9a bf b9 99 99 */
+ printf("8\n");
+ exit(0);
+ }
+#endif
+#if DOUBLESIZE == 16
+ if (b[0] == 0x9A && b[15] == 0xBF) {
+ /* IEEE 754 128-bit little-endian */
+ printf("5\n");
+ exit(0);
+ }
+ if (b[0] == 0xBF && b[15] == 0x9A) {
+ /* IEEE 754 128-bit big-endian */
+ printf("6\n");
+ exit(0);
+ }
+#endif
+ /* Rumoredly some old ARM processors have 'mixed endian' doubles,
+ * two 32-bit little endians stored in big-endian order. */
+ /* Then there are old mainframe/miniframe formats like VAX, IBM, and CRAY.
+ * Whether those environments can still build Perl is debatable. */
+ printf("-1\n"); /* unknown */
+ exit(0);
+}
+EOP
+set try
+if eval $compile; then
+ doublekind=`$run ./try`
+else
+ doublekind=-1
+fi
+case "$doublekind" in
+1) echo "You have IEEE 754 32-bit little endian doubles." >&4 ;;
+2) echo "You have IEEE 754 32-bit big endian doubles." >&4 ;;
+3) echo "You have IEEE 754 64-bit little endian doubles." >&4 ;;
+4) echo "You have IEEE 754 64-bit big endian doubles." >&4 ;;
+5) echo "You have IEEE 754 128-bit little endian doubles." >&4 ;;
+6) echo "You have IEEE 754 128-bit big endian doubles." >&4 ;;
+*) echo "Cannot figure out your double. You VAX, or something?" >&4 ;;
+esac
+$rm_try
+
: check for long doubles
echo " "
echo "Checking to see if you have long double..." >&4
esac
$rm_try
+echo " "
$echo "Checking the kind of long doubles you have..." >&4
case "$d_longdbl" in
define)
#$i_float I_FLOAT
#$i_stdlib I_STDLIB
#define LONGDBLSIZE $longdblsize
+#define DOUBLESIZE $doublesize
#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 DOUBLESIZE == LONGDBLSIZE
+ printf("0\n"); /* if it floats like double */
+ exit(0);
+#endif
#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 */
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 ;;
+4) echo "You have x86 80-bit big endian long doubles." >& 4 ;;
+5) echo "You have 128-bit little-endian double-double long doubles." >& 4 ;;
+6) echo "You have 128-bit big-endian double-double long doubles." >& 4 ;;
*) echo "Cannot figure out your long double." >&4 ;;
esac
$rm_try
+: Check print/scan long double stuff
+echo " "
+
+if $test X"$d_longdbl" = X"$define"; then
+
+echo "Checking how to print long doubles..." >&4
+
+if $test X"$sPRIfldbl" = X -a X"$doublesize" = X"$longdblsize"; then
+ $cat >try.c <<'EOCP'
+#include <sys/types.h>
+#include <stdio.h>
+int main() {
+ double d = 123.456;
+ printf("%.3f\n", d);
+}
+EOCP
+ set try
+ if eval $compile; then
+ yyy=`$run ./try`
+ case "$yyy" in
+ 123.456)
+ sPRIfldbl='"f"'; sPRIgldbl='"g"'; sPRIeldbl='"e"';
+ sPRIFUldbl='"F"'; sPRIGUldbl='"G"'; sPRIEUldbl='"E"';
+ echo "We will use %f."
+ ;;
+ esac
+ fi
+fi
+
+if $test X"$sPRIfldbl" = X; then
+ $cat >try.c <<'EOCP'
+#include <sys/types.h>
+#include <stdio.h>
+int main() {
+ long double d = 123.456;
+ printf("%.3Lf\n", d);
+}
+EOCP
+ set try
+ if eval $compile; then
+ yyy=`$run ./try`
+ case "$yyy" in
+ 123.456)
+ sPRIfldbl='"Lf"'; sPRIgldbl='"Lg"'; sPRIeldbl='"Le"';
+ sPRIFUldbl='"LF"'; sPRIGUldbl='"LG"'; sPRIEUldbl='"LE"';
+ echo "We will use %Lf."
+ ;;
+ esac
+ fi
+fi
+
+if $test X"$sPRIfldbl" = X; then
+ $cat >try.c <<'EOCP'
+#include <sys/types.h>
+#include <stdio.h>
+int main() {
+ long double d = 123.456;
+ printf("%.3llf\n", d);
+}
+EOCP
+ set try
+ if eval $compile; then
+ yyy=`$run ./try`
+ case "$yyy" in
+ 123.456)
+ sPRIfldbl='"llf"'; sPRIgldbl='"llg"'; sPRIeldbl='"lle"';
+ sPRIFUldbl='"llF"'; sPRIGUldbl='"llG"'; sPRIEUldbl='"llE"';
+ echo "We will use %llf."
+ ;;
+ esac
+ fi
+fi
+
+if $test X"$sPRIfldbl" = X; then
+ $cat >try.c <<'EOCP'
+#include <sys/types.h>
+#include <stdio.h>
+int main() {
+ long double d = 123.456;
+ printf("%.3lf\n", d);
+}
+EOCP
+ set try
+ if eval $compile; then
+ yyy=`$run ./try`
+ case "$yyy" in
+ 123.456)
+ sPRIfldbl='"lf"'; sPRIgldbl='"lg"'; sPRIeldbl='"le"';
+ sPRIFUldbl='"lF"'; sPRIGUldbl='"lG"'; sPRIEUldbl='"lE"';
+ echo "We will use %lf."
+ ;;
+ esac
+ fi
+fi
+
+if $test X"$sPRIfldbl" = X; then
+ echo "Cannot figure out how to print long doubles." >&4
+else
+ sSCNfldbl=$sPRIfldbl # expect consistency
+fi
+
+$rm_try
+
+fi # d_longdbl
+
+case "$sPRIfldbl" in
+'') d_PRIfldbl="$undef"; d_PRIgldbl="$undef"; d_PRIeldbl="$undef";
+ d_PRIFUldbl="$undef"; d_PRIGUldbl="$undef"; d_PRIEUldbl="$undef";
+ d_SCNfldbl="$undef";
+ ;;
+*) d_PRIfldbl="$define"; d_PRIgldbl="$define"; d_PRIeldbl="$define";
+ d_PRIFUldbl="$define"; d_PRIGUldbl="$define"; d_PRIEUldbl="$define";
+ d_SCNfldbl="$define";
+ ;;
+esac
+
+: Before committing on uselongdouble, see whether that looks sane.
+if $test "$uselongdouble" = "$define"; then
+ message=""
+ echo " "
+ echo "Checking if your long double math functions work right..." >&4
+ $cat > try.c <<EOF
+#include <math.h>
+#include <stdio.h>
+int main() {
+ printf("%"$sPRIgldbl"\n", sqrtl(logl(expl(cosl(sinl(0.0L))))+powl(2.0L, 3.0L)));
+}
+EOF
+ case "$osname:$gccversion" in
+ aix:) saveccflags="$ccflags"
+ ccflags="$ccflags -qlongdouble" ;; # to avoid core dump
+ esac
+ set try
+ if eval $compile_ok; then
+ yyy=`$run ./try`
+ fi
+ case "$yyy" in
+ 3) echo "Your long double math functions are working correctly." >&4 ;;
+ *) echo "Your long double math functions are broken, not using long doubles." >&4
+ uselongdouble=$undef
+ ;;
+ esac
+ $rm_try
+ case "$osname:$gccversion" in
+ aix:) ccflags="$saveccflags" ;; # restore
+ esac
+fi
: determine the architecture name
echo " "
esac
;;
esac
+case "$usequadmath" in
+$define)
+ echo "quadmath selected." >&4
+ case "$archname" in
+ *-ld*) echo "...and architecture name already has -quadmath." >&4
+ ;;
+ *) archname="$archname-quadmath"
+ echo "...setting architecture name to $archname." >&4
+ ;;
+ esac
+ ;;
+esac
if $test -f archname.cbu; then
echo "Your platform has some specific hints for architecture name, using them..."
. ./archname.cbu
set qgcvt d_qgcvt
eval $inlibc
-: Check print/scan long double stuff
-echo " "
-
-if $test X"$d_longdbl" = X"$define"; then
-
-echo "Checking how to print long doubles..." >&4
-
-if $test X"$sPRIfldbl" = X -a X"$doublesize" = X"$longdblsize"; then
- $cat >try.c <<'EOCP'
-#include <sys/types.h>
-#include <stdio.h>
-int main() {
- double d = 123.456;
- printf("%.3f\n", d);
-}
-EOCP
- set try
- if eval $compile; then
- yyy=`$run ./try`
- case "$yyy" in
- 123.456)
- sPRIfldbl='"f"'; sPRIgldbl='"g"'; sPRIeldbl='"e"';
- sPRIFUldbl='"F"'; sPRIGUldbl='"G"'; sPRIEUldbl='"E"';
- echo "We will use %f."
- ;;
- esac
- fi
-fi
-
-if $test X"$sPRIfldbl" = X; then
- $cat >try.c <<'EOCP'
-#include <sys/types.h>
-#include <stdio.h>
-int main() {
- long double d = 123.456;
- printf("%.3Lf\n", d);
-}
-EOCP
- set try
- if eval $compile; then
- yyy=`$run ./try`
- case "$yyy" in
- 123.456)
- sPRIfldbl='"Lf"'; sPRIgldbl='"Lg"'; sPRIeldbl='"Le"';
- sPRIFUldbl='"LF"'; sPRIGUldbl='"LG"'; sPRIEUldbl='"LE"';
- echo "We will use %Lf."
- ;;
- esac
- fi
-fi
-
-if $test X"$sPRIfldbl" = X; then
- $cat >try.c <<'EOCP'
-#include <sys/types.h>
-#include <stdio.h>
-int main() {
- long double d = 123.456;
- printf("%.3llf\n", d);
-}
-EOCP
- set try
- if eval $compile; then
- yyy=`$run ./try`
- case "$yyy" in
- 123.456)
- sPRIfldbl='"llf"'; sPRIgldbl='"llg"'; sPRIeldbl='"lle"';
- sPRIFUldbl='"llF"'; sPRIGUldbl='"llG"'; sPRIEUldbl='"llE"';
- echo "We will use %llf."
- ;;
- esac
- fi
-fi
-
-if $test X"$sPRIfldbl" = X; then
- $cat >try.c <<'EOCP'
-#include <sys/types.h>
-#include <stdio.h>
-int main() {
- long double d = 123.456;
- printf("%.3lf\n", d);
-}
-EOCP
- set try
- if eval $compile; then
- yyy=`$run ./try`
- case "$yyy" in
- 123.456)
- sPRIfldbl='"lf"'; sPRIgldbl='"lg"'; sPRIeldbl='"le"';
- sPRIFUldbl='"lF"'; sPRIGUldbl='"lG"'; sPRIEUldbl='"lE"';
- echo "We will use %lf."
- ;;
- esac
- fi
-fi
-
-if $test X"$sPRIfldbl" = X; then
- echo "Cannot figure out how to print long doubles." >&4
-else
- sSCNfldbl=$sPRIfldbl # expect consistency
-fi
-
-$rm_try
-
-fi # d_longdbl
-
-case "$sPRIfldbl" in
-'') d_PRIfldbl="$undef"; d_PRIgldbl="$undef"; d_PRIeldbl="$undef";
- d_PRIFUldbl="$undef"; d_PRIGUldbl="$undef"; d_PRIEUldbl="$undef";
- d_SCNfldbl="$undef";
- ;;
-*) d_PRIfldbl="$define"; d_PRIgldbl="$define"; d_PRIeldbl="$define";
- d_PRIFUldbl="$define"; d_PRIGUldbl="$define"; d_PRIEUldbl="$define";
- d_SCNfldbl="$define";
- ;;
-esac
-
: Check how to convert floats to strings.
if test "X$d_Gconvert" = X; then
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 i_sysfile
eval $setvar
+: see if acosh exists
+set acosh d_acosh
+eval $inlibc
+
+: see if asinh exists
+set asinh d_asinh
+eval $inlibc
+
+: see if atanh exists
+set atanh d_atanh
+eval $inlibc
+
+: see if cbrt exists
+set cbrt d_cbrt
+eval $inlibc
+
+: see if copysign exists
+set copysign d_copysign
+eval $inlibc
+
+: see if erf exists
+set erf d_erf
+eval $inlibc
+
+: see if erfc exists
+set erfc d_erfc
+eval $inlibc
+
+: see if exp2 exists
+set exp2 d_exp2
+eval $inlibc
+
+: see if expm1 exists
+set expm1 d_expm1
+eval $inlibc
+
+: see if fdim exists
+set fdim d_fdim
+eval $inlibc
+
+: see if fma exists
+set fma d_fma
+eval $inlibc
+
+: see if fmax exists
+set fmax d_fmax
+eval $inlibc
+
+: see if fmin exists
+set fmin d_fmin
+eval $inlibc
+
+: see if hypot exists
+set hypot d_hypot
+eval $inlibc
+
+: see if ilogb exists
+set ilogb d_ilogb
+eval $inlibc
+
+: see if lgamma exists
+set lgamma d_lgamma
+eval $inlibc
+
+: see if lgamma_r exists
+set lgamma_r d_lgamma_r
+eval $inlibc
+
+: see if llrint exists
+set llrint d_llrint
+eval $inlibc
+
+: see if llround exists
+set llround d_llround
+eval $inlibc
+
+: see if log1p exists
+set log1p d_log1p
+eval $inlibc
+
+: see if log2 exists
+set log2 d_log2
+eval $inlibc
+
+: see if logb exists
+set logb d_logb
+eval $inlibc
+
+: see if lrint exists
+set lrint d_lrint
+eval $inlibc
+
+: see if lround exists
+set lround d_lround
+eval $inlibc
+
+: see if nan exists
+set nan d_nan
+eval $inlibc
+
+: see if nearbyint exists
+set nearbyint d_nearbyint
+eval $inlibc
+
+: see if nextafter exists
+set nextafter d_nextafter
+eval $inlibc
+
+: see if nexttoward exists
+set nexttoward d_nexttoward
+eval $inlibc
+
+: see if remainder exists
+set remainder d_remainder
+eval $inlibc
+
+: see if remquo exists
+set remquo d_remquo
+eval $inlibc
+
+: see if rint exists
+set rint d_rint
+eval $inlibc
+
+: see if round exists
+set round d_round
+eval $inlibc
+
+: see if scalbn exists
+set scalbn d_scalbn
+eval $inlibc
+
+: see if tgamma exists
+set tgamma d_tgamma
+eval $inlibc
+
+: see if trunc exists
+set trunc d_trunc
+eval $inlibc
+
: see if fcntl.h is there
val=''
set fcntl.h val
set isinfl d_isinfl
eval $inlibc
+: check for isless
+echo "Checking to see if you have isless..." >&4
+$cat >try.c <<EOCP
+#$i_math I_MATH
+#ifdef I_MATH
+#include <math.h>
+#endif
+int main() { return isless(0.0); }
+EOCP
+set try
+if eval $compile; then
+ val="$define"
+ echo "You have isless."
+else
+ val="$undef"
+ echo "You do not have isless."
+fi
+$rm_try
+set d_isless
+eval $setvar
+
: check for isnan
echo "Checking to see if you have isnan..." >&4
$cat >try.c <<EOCP
set isnanl d_isnanl
eval $inlibc
+: check for isnormal
+echo "Checking to see if you have isnormal..." >&4
+$cat >try.c <<EOCP
+#$i_math I_MATH
+#ifdef I_MATH
+#include <math.h>
+#endif
+int main() { return isnormal(0.0); }
+EOCP
+set try
+if eval $compile; then
+ val="$define"
+ echo "You have isnormal."
+else
+ val="$undef"
+ echo "You do not have isnormal."
+fi
+$rm_try
+set d_isnormal
+eval $setvar
+
: see if j0 exists
set j0 d_j0
eval $inlibc
d_archlib='$d_archlib'
d_asctime64='$d_asctime64'
d_asctime_r='$d_asctime_r'
+d_asinh='$d_asinh'
+d_atanh='$d_atanh'
d_atolf='$d_atolf'
d_atoll='$d_atoll'
d_attribute_deprecated='$d_attribute_deprecated'
d_c99_variadic_macros='$d_c99_variadic_macros'
d_casti32='$d_casti32'
d_castneg='$d_castneg'
+d_cbrt='$d_cbrt'
d_charvspr='$d_charvspr'
d_chown='$d_chown'
d_chroot='$d_chroot'
d_closedir='$d_closedir'
d_cmsghdr_s='$d_cmsghdr_s'
d_const='$d_const'
+d_copysign='$d_copysign'
d_copysignl='$d_copysignl'
d_cplusplus='$d_cplusplus'
d_crypt='$d_crypt'
d_endsent='$d_endsent'
d_endservent_r='$d_endservent_r'
d_eofnblk='$d_eofnblk'
+d_erf='$d_erf'
+d_erfc='$d_erfc'
d_eunice='$d_eunice'
+d_exp2='$d_exp2'
+d_expm1='$d_expm1'
d_faststdio='$d_faststdio'
d_fchdir='$d_fchdir'
d_fchmod='$d_fchmod'
d_fcntl_can_lock='$d_fcntl_can_lock'
d_fd_macros='$d_fd_macros'
d_fd_set='$d_fd_set'
+d_fdim='$d_fdim'
d_fds_bits='$d_fds_bits'
d_fegetround='$d_fegetround'
d_fgetpos='$d_fgetpos'
d_flexfnam='$d_flexfnam'
d_flock='$d_flock'
d_flockproto='$d_flockproto'
+d_fma='$d_fma'
+d_fmax='$d_fmax'
+d_fmin='$d_fmin'
d_fork='$d_fork'
d_fp_class='$d_fp_class'
d_fp_classify='$d_fp_classify'
d_grpasswd='$d_grpasswd'
d_hasmntopt='$d_hasmntopt'
d_htonl='$d_htonl'
+d_hypot='$d_hypot'
+d_ilogb='$d_ilogb'
d_ilogbl='$d_ilogbl'
d_inc_version_list='$d_inc_version_list'
d_index='$d_index'
d_isinfl='$d_isinfl'
d_isnan='$d_isnan'
d_isnanl='$d_isnanl'
+d_isnormal='$d_isnormal'
d_j0='$d_j0'
d_j0l='$d_j0l'
d_killpg='$d_killpg'
d_lchown='$d_lchown'
+d_lc_monetary_2008='$d_lc_monetary_2008'
d_ldbl_dig='$d_ldbl_dig'
d_ldexpl='$d_ldexpl'
+d_lgamma='$d_lgamma'
+d_lgamma_r='$d_lgamma_r'
d_libm_lib_version='$d_libm_lib_version'
d_libname_unique='$d_libname_unique'
d_link='$d_link'
+d_llrint='$d_llrint'
+d_llround='$d_llround'
d_localtime64='$d_localtime64'
d_localtime_r='$d_localtime_r'
d_localtime_r_needs_tzset='$d_localtime_r_needs_tzset'
d_locconv='$d_locconv'
-d_lc_monetary_2008='$d_lc_monetary_2008'
+d_lgamma='$d_lgamma'
d_lockf='$d_lockf'
+d_log1p='$d_log1p'
+d_log2='$d_log2'
+d_logb='$d_logb'
d_longdbl='$d_longdbl'
d_longlong='$d_longlong'
+d_lrint='$d_lrint'
+d_lround='$d_lround'
d_lseekproto='$d_lseekproto'
d_lstat='$d_lstat'
d_madvise='$d_madvise'
d_msync='$d_msync'
d_munmap='$d_munmap'
d_mymalloc='$d_mymalloc'
+d_nan='$d_nan'
d_ndbm='$d_ndbm'
d_ndbm_h_uses_prototypes='$d_ndbm_h_uses_prototypes'
+d_nearbyint='$d_nearbyint'
+d_nextafter='$d_nextafter'
+d_nexttoward='$d_nexttoward'
d_nice='$d_nice'
d_nl_langinfo='$d_nl_langinfo'
d_nv_preserves_uv='$d_nv_preserves_uv'
d_readlink='$d_readlink'
d_readv='$d_readv'
d_recvmsg='$d_recvmsg'
+d_remainder='$d_remainder'
+d_remquo='$d_remquo'
d_rename='$d_rename'
d_rewinddir='$d_rewinddir'
+d_rint='$d_rint'
d_rmdir='$d_rmdir'
+d_round='$d_round'
d_safebcpy='$d_safebcpy'
d_safemcpy='$d_safemcpy'
d_sanemcmp='$d_sanemcmp'
d_sbrkproto='$d_sbrkproto'
+d_scalbn='$d_scalbn'
d_scalbnl='$d_scalbnl'
d_sched_yield='$d_sched_yield'
d_scm_rights='$d_scm_rights'
d_tcsetpgrp='$d_tcsetpgrp'
d_telldir='$d_telldir'
d_telldirproto='$d_telldirproto'
+d_tgamma='$d_tgamma'
d_time='$d_time'
d_timegm='$d_timegm'
d_times='$d_times'
d_tm_tm_zone='$d_tm_tm_zone'
d_tmpnam_r='$d_tmpnam_r'
d_truncate='$d_truncate'
+d_trunc='$d_trunc'
d_truncl='$d_truncl'
d_ttyname_r='$d_ttyname_r'
d_tzname='$d_tzname'
direntrytype='$direntrytype'
dlext='$dlext'
dlsrc='$dlsrc'
+doublekind='$doublekind'
doublesize='$doublesize'
drand01='$drand01'
drand48_r_proto='$drand48_r_proto'
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='5'
+api_subversion='6'
api_version='21'
-api_versionstring='5.21.5'
+api_versionstring='5.21.6'
ar='ar'
-archlib='/usr/lib/perl5/5.21.5/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.21.5/armv4l-linux'
+archlib='/usr/lib/perl5/5.21.6/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.21.6/armv4l-linux'
archname64=''
archname='armv4l-linux'
archobjs=''
cat='cat'
cc='cc'
cccdlflags='-fpic'
-ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.21.5/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.21.6/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_archlib='define'
d_asctime64='undef'
d_asctime_r='undef'
+d_asinh='undef'
+d_atanh='undef'
d_atolf='undef'
d_atoll='define'
d_attribute_deprecated='undef'
d_c99_variadic_macros='undef'
d_casti32='define'
d_castneg='define'
+d_cbrt='undef'
d_charvspr='undef'
d_chown='define'
d_chroot='define'
d_closedir='define'
d_cmsghdr_s='define'
d_const='define'
+d_copysign='undef'
d_copysignl='define'
d_cplusplus='undef'
d_crypt='define'
d_endsent='define'
d_endservent_r='undef'
d_eofnblk='define'
+d_erf='undef'
+d_erfc='undef'
d_eunice='undef'
+d_exp2='undef'
+d_expm1='undef'
d_faststdio='define'
d_fchdir='define'
d_fchmod='define'
d_fcntl_can_lock='define'
d_fd_macros='define'
d_fd_set='define'
+d_fdim='undef'
d_fds_bits='undef'
d_fegetround='define'
d_fgetpos='define'
d_flexfnam='define'
d_flock='define'
d_flockproto='define'
+d_fma='undef'
+d_fmax='undef'
+d_fmin='undef'
d_fork='define'
d_fp_class='undef'
d_fp_classify='undef'
d_grpasswd='define'
d_hasmntopt='define'
d_htonl='define'
+d_hypot='undef'
+d_ilogb='undef'
d_ilogbl='define'
d_inc_version_list='define'
d_index='undef'
d_isinfl='define'
d_isnan='define'
d_isnanl='define'
+d_isnormal='undef'
d_j0='define'
d_j0l='define'
d_killpg='define'
d_lchown='define'
d_ldbl_dig='define'
d_ldexpl='define'
+d_lgamma='undef'
+d_lgamma_r='undef'
d_libm_lib_version='define'
d_link='define'
+d_llrint='undef'
+d_llround='undef'
d_localtime64='undef'
d_localtime_r='undef'
d_localtime_r_needs_tzset='undef'
d_locconv='define'
d_lockf='define'
+d_log1p='undef'
+d_log2='undef'
+d_logb='undef'
d_longdbl='define'
d_longlong='define'
+d_lrint='undef'
+d_lround='undef'
d_lseekproto='define'
d_lstat='define'
d_madvise='define'
d_msync='define'
d_munmap='define'
d_mymalloc='undef'
+d_nan='undef'
d_ndbm_h_uses_prototypes='undef'
+d_nearbyint='undef'
+d_nextafter='undef'
+d_nexttoward='undef'
d_nice='define'
d_nl_langinfo='define'
d_nv_preserves_uv='define'
d_readlink='define'
d_readv='define'
d_recvmsg='define'
+d_remainder='undef'
+d_remquo='undef'
d_rename='define'
d_rewinddir='define'
+d_rint='undef'
d_rmdir='define'
+d_round='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='define'
d_sbrkproto='define'
+d_scalbn='undef'
d_scalbnl='define'
d_sched_yield='define'
d_scm_rights='define'
d_tcsetpgrp='define'
d_telldir='define'
d_telldirproto='define'
+d_tgamma='undef'
d_time='define'
d_timegm='define'
d_times='define'
d_tm_tm_gmtoff='define'
d_tm_tm_zone='define'
d_tmpnam_r='undef'
+d_trunc='undef'
d_truncate='define'
d_truncl='define'
d_ttyname_r='undef'
direntrytype='struct dirent'
dlext='so'
dlsrc='dl_dlopen.xs'
+doublekind='3'
doublesize='8'
drand01='Perl_drand48()'
drand48_r_proto='0'
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='./install_me_here/usr/lib/perl5/5.21.5/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.21.6/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.5'
+installprivlib='./install_me_here/usr/lib/perl5/5.21.6'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.5/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.6/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.5'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.6'
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.5'
-privlibexp='/usr/lib/perl5/5.21.5'
+privlib='/usr/lib/perl5/5.21.6'
+privlibexp='/usr/lib/perl5/5.21.6'
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.5/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.21.5/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.21.6/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.21.6/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.21.5'
+sitelib='/usr/lib/perl5/site_perl/5.21.6'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.21.5'
+sitelibexp='/usr/lib/perl5/site_perl/5.21.6'
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='5'
+subversion='6'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.21.5'
-version_patchlevel_string='version 21 subversion 5'
+version='5.21.6'
+version_patchlevel_string='version 21 subversion 6'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_argc=0
PERL_REVISION=5
PERL_VERSION=21
-PERL_SUBVERSION=5
+PERL_SUBVERSION=6
PERL_API_REVISION=5
PERL_API_VERSION=21
-PERL_API_SUBVERSION=5
+PERL_API_SUBVERSION=6
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='5'
+api_subversion='6'
api_version='21'
-api_versionstring='5.21.5'
+api_versionstring='5.21.6'
ar='ar'
-archlib='/usr/lib/perl5/5.21.5/armv4l-linux'
-archlibexp='/usr/lib/perl5/5.21.5/armv4l-linux'
+archlib='/usr/lib/perl5/5.21.6/armv4l-linux'
+archlibexp='/usr/lib/perl5/5.21.6/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.5/armv4l-linux/CORE'
+ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.21.6/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.5/armv4l-linux'
+installarchlib='./install_me_here/usr/lib/perl5/5.21.6/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.5'
+installprivlib='./install_me_here/usr/lib/perl5/5.21.6'
installscript='./install_me_here/usr/bin'
-installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.5/armv4l-linux'
+installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.6/armv4l-linux'
installsitebin='./install_me_here/usr/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.5'
+installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.6'
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.5'
-privlibexp='/usr/lib/perl5/5.21.5'
+privlib='/usr/lib/perl5/5.21.6'
+privlibexp='/usr/lib/perl5/5.21.6'
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.5/armv4l-linux'
-sitearchexp='/usr/lib/perl5/site_perl/5.21.5/armv4l-linux'
+sitearch='/usr/lib/perl5/site_perl/5.21.6/armv4l-linux'
+sitearchexp='/usr/lib/perl5/site_perl/5.21.6/armv4l-linux'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/usr/lib/perl5/site_perl/5.21.5'
+sitelib='/usr/lib/perl5/site_perl/5.21.6'
sitelib_stem='/usr/lib/perl5/site_perl'
-sitelibexp='/usr/lib/perl5/site_perl/5.21.5'
+sitelibexp='/usr/lib/perl5/site_perl/5.21.6'
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='5'
+subversion='6'
sysman='/usr/share/man/man1'
tail=''
tar=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.21.5'
-version_patchlevel_string='version 21 subversion 5'
+version='5.21.6'
+version_patchlevel_string='version 21 subversion 6'
versiononly='undef'
vi=''
xlibpth='/usr/lib/386 /lib/386'
config_argc=0
PERL_REVISION=5
PERL_VERSION=21
-PERL_SUBVERSION=5
+PERL_SUBVERSION=6
PERL_API_REVISION=5
PERL_API_VERSION=21
-PERL_API_SUBVERSION=5
+PERL_API_SUBVERSION=6
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
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.
+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
=item Directories for the perl distribution
-By default, Configure will use the following directories for 5.21.5.
+By default, Configure will use the following directories for 5.21.6.
$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
make realclean
The only difference between the two is that make distclean also removes
-your old config.sh and Policy.sh files. (A plain 'make clean' will not
-delete the makefiles used for rebuilding perl, and will also not delete
-a number of library and utility files extracted during the build process.)
+your old config.sh and Policy.sh files. (A plain 'make clean' is now
+eqivalent to 'make realclean'.)
If you are upgrading from a previous version of perl, or if you
change systems or compilers or make other significant changes, or if
=head1 Coexistence with earlier versions of perl 5
-Perl 5.21.5 is not binary compatible with earlier versions of Perl.
+Perl 5.21.6 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.5
+ sh Configure -Dprefix=/opt/perl5.21.6
-and adding /opt/perl5.21.5/bin to the shell PATH variable. Such users
+and adding /opt/perl5.21.6/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.3 or earlier
+=head2 Upgrading from 5.21.5 or earlier
-B<Perl 5.21.5 may not be binary compatible with Perl 5.21.4 or
+B<Perl 5.21.6 may not be binary compatible with Perl 5.21.5 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.5. If you find you do need to rebuild an extension with
-5.21.5, you may safely do so without disturbing the older
+used with 5.21.6. If you find you do need to rebuild an extension with
+5.21.6, 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.5 is as follows (under $Config{prefix}):
+in Linux with perl-5.21.6 is as follows (under $Config{prefix}):
./bin/perl
- ./lib/perl5/5.21.5/strict.pm
- ./lib/perl5/5.21.5/warnings.pm
- ./lib/perl5/5.21.5/i686-linux/File/Glob.pm
- ./lib/perl5/5.21.5/feature.pm
- ./lib/perl5/5.21.5/XSLoader.pm
- ./lib/perl5/5.21.5/i686-linux/auto/File/Glob/Glob.so
+ ./lib/perl5/5.21.6/strict.pm
+ ./lib/perl5/5.21.6/warnings.pm
+ ./lib/perl5/5.21.6/i686-linux/File/Glob.pm
+ ./lib/perl5/5.21.6/feature.pm
+ ./lib/perl5/5.21.6/XSLoader.pm
+ ./lib/perl5/5.21.6/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/CPAN-Meta/t/merge.t
cpan/CPAN-Meta/t/meta-obj.t
cpan/CPAN-Meta/t/no-index.t
+cpan/CPAN-Meta/t/optional_feature-merge.t
cpan/CPAN-Meta/t/prereqs-finalize.t
cpan/CPAN-Meta/t/prereqs-merge.t
cpan/CPAN-Meta/t/prereqs.t
cpan/CPAN-Meta/t/repository.t
cpan/CPAN-Meta/t/save-load.t
-cpan/CPAN-Meta/t/strings.t
cpan/CPAN-Meta/t/validator.t
cpan/CPAN-Meta-YAML/lib/CPAN/Meta/YAML.pm CPAN-Meta-YAML files
cpan/CPAN-Meta-YAML/t/01_api.t
cpan/Encode/t/Unicode.t test script
cpan/Encode/t/utf8ref.t test script
cpan/Encode/t/utf8strict.t test script
+cpan/Encode/t/utf8warnings.t
cpan/Encode/TW/Makefile.PL Encode extension
cpan/Encode/TW/TW.pm Encode extension
cpan/Encode/ucm/8859-10.ucm Unicode Character Map
cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm Locates libraries
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm MakeMaker wrapper for Config
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/FAQ.pod MakeMaker FAQ
+cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Locale.pm
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm Write Makefiles for extensions
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod Writing a module with MakeMaker
+cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version.pm
+cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version/regex.pm
+cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version/vpp.pm
cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm Writes a bootstrap file (see MakeMaker)
cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm Writes a linker options file for extensions
cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm MakeMaker methods for AIX
cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/Problem.pm MakeMaker test utilities
cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/Recurs.pm MakeMaker test utilities
cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/SAS.pm MakeMaker test utilities
+cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/Unicode.pm
cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/XS.pm MakeMaker test utilities
cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Utils.pm MakeMaker test utilities
cpan/ExtUtils-MakeMaker/t/lib/TieIn.pm Testing library for dummy input handles
cpan/ExtUtils-MakeMaker/t/testdata/reallylongdirectoryname/arch1/Config.pm test data for MakeMaker
cpan/ExtUtils-MakeMaker/t/testdata/reallylongdirectoryname/arch2/Config.pm test data for MakeMaker
cpan/ExtUtils-MakeMaker/t/testlib.t See if ExtUtils::testlib works
+cpan/ExtUtils-MakeMaker/t/unicode.t
cpan/ExtUtils-MakeMaker/t/VERSION_FROM.t See if MakeMaker's VERSION_FROM works
+cpan/ExtUtils-MakeMaker/t/vstrings.t
cpan/ExtUtils-MakeMaker/t/WriteEmptyMakefile.t See if WriteEmptyMakefile works
cpan/ExtUtils-MakeMaker/t/writemakefile_args.t See if WriteMakefile works
cpan/ExtUtils-MakeMaker/t/xs.t Part of MakeMaker's test suite
cpan/Getopt-Long/t/gol-oo.t See if Getopt::Long works
cpan/Getopt-Long/t/gol-xargv.t See if Getopt::Long works
cpan/Getopt-Long/t/gol-xstring.t See if Getopt::Long works
+cpan/HTTP-Tiny/corpus/auth-01.txt
+cpan/HTTP-Tiny/corpus/auth-02.txt
+cpan/HTTP-Tiny/corpus/auth-03.txt
+cpan/HTTP-Tiny/corpus/auth-04.txt
+cpan/HTTP-Tiny/corpus/auth-05.txt
+cpan/HTTP-Tiny/corpus/cookies-01.txt
+cpan/HTTP-Tiny/corpus/cookies-02.txt
+cpan/HTTP-Tiny/corpus/cookies-03.txt
+cpan/HTTP-Tiny/corpus/cookies-04.txt
+cpan/HTTP-Tiny/corpus/cookies-05.txt
+cpan/HTTP-Tiny/corpus/cookies-06.txt
+cpan/HTTP-Tiny/corpus/cookies-07.txt
+cpan/HTTP-Tiny/corpus/delete-01.txt
+cpan/HTTP-Tiny/corpus/form-01.txt
+cpan/HTTP-Tiny/corpus/form-02.txt
+cpan/HTTP-Tiny/corpus/form-03.txt
+cpan/HTTP-Tiny/corpus/form-04.txt
+cpan/HTTP-Tiny/corpus/form-05.txt
+cpan/HTTP-Tiny/corpus/get-01.txt
+cpan/HTTP-Tiny/corpus/get-02.txt
+cpan/HTTP-Tiny/corpus/get-03.txt
+cpan/HTTP-Tiny/corpus/get-04.txt
+cpan/HTTP-Tiny/corpus/get-05.txt
+cpan/HTTP-Tiny/corpus/get-06.txt
+cpan/HTTP-Tiny/corpus/get-07.txt
+cpan/HTTP-Tiny/corpus/get-08.txt
+cpan/HTTP-Tiny/corpus/get-09.txt
+cpan/HTTP-Tiny/corpus/get-10.txt
+cpan/HTTP-Tiny/corpus/get-11.txt
+cpan/HTTP-Tiny/corpus/get-12.txt
+cpan/HTTP-Tiny/corpus/get-13.txt
+cpan/HTTP-Tiny/corpus/get-14.txt
+cpan/HTTP-Tiny/corpus/get-15.txt
+cpan/HTTP-Tiny/corpus/get-16.txt
+cpan/HTTP-Tiny/corpus/get-17.txt
+cpan/HTTP-Tiny/corpus/get-18.txt
+cpan/HTTP-Tiny/corpus/get-19.txt
+cpan/HTTP-Tiny/corpus/get-20.txt
+cpan/HTTP-Tiny/corpus/get-21.txt
+cpan/HTTP-Tiny/corpus/head-01.txt
+cpan/HTTP-Tiny/corpus/keepalive-01.txt
+cpan/HTTP-Tiny/corpus/keepalive-02.txt
+cpan/HTTP-Tiny/corpus/keepalive-03.txt
+cpan/HTTP-Tiny/corpus/keepalive-04.txt
+cpan/HTTP-Tiny/corpus/keepalive-05.txt
+cpan/HTTP-Tiny/corpus/mirror-01.txt
+cpan/HTTP-Tiny/corpus/mirror-02.txt
+cpan/HTTP-Tiny/corpus/mirror-03.txt
+cpan/HTTP-Tiny/corpus/mirror-04.txt
+cpan/HTTP-Tiny/corpus/mirror-05.txt
+cpan/HTTP-Tiny/corpus/post-01.txt
+cpan/HTTP-Tiny/corpus/proxy-auth-01.txt
+cpan/HTTP-Tiny/corpus/put-01.txt
+cpan/HTTP-Tiny/corpus/put-02.txt
+cpan/HTTP-Tiny/corpus/put-03.txt
+cpan/HTTP-Tiny/corpus/put-04.txt
+cpan/HTTP-Tiny/corpus/put-05.txt
+cpan/HTTP-Tiny/corpus/redirect-01.txt
+cpan/HTTP-Tiny/corpus/redirect-02.txt
+cpan/HTTP-Tiny/corpus/redirect-03.txt
+cpan/HTTP-Tiny/corpus/redirect-04.txt
+cpan/HTTP-Tiny/corpus/redirect-05.txt
+cpan/HTTP-Tiny/corpus/redirect-06.txt
+cpan/HTTP-Tiny/corpus/redirect-07.txt
+cpan/HTTP-Tiny/corpus/redirect-08.txt
+cpan/HTTP-Tiny/corpus/redirect-09.txt
cpan/HTTP-Tiny/lib/HTTP/Tiny.pm
cpan/HTTP-Tiny/t/000_load.t
cpan/HTTP-Tiny/t/001_api.t
cpan/HTTP-Tiny/t/162_proxy_auth.t
cpan/HTTP-Tiny/t/170_keepalive.t
cpan/HTTP-Tiny/t/BrokenCookieJar.pm
-cpan/HTTP-Tiny/t/cases/auth-01.txt
-cpan/HTTP-Tiny/t/cases/auth-02.txt
-cpan/HTTP-Tiny/t/cases/auth-03.txt
-cpan/HTTP-Tiny/t/cases/auth-04.txt
-cpan/HTTP-Tiny/t/cases/auth-05.txt
-cpan/HTTP-Tiny/t/cases/cookies-01.txt
-cpan/HTTP-Tiny/t/cases/cookies-02.txt
-cpan/HTTP-Tiny/t/cases/cookies-03.txt
-cpan/HTTP-Tiny/t/cases/cookies-04.txt
-cpan/HTTP-Tiny/t/cases/cookies-05.txt
-cpan/HTTP-Tiny/t/cases/cookies-06.txt
-cpan/HTTP-Tiny/t/cases/cookies-07.txt
-cpan/HTTP-Tiny/t/cases/delete-01.txt
-cpan/HTTP-Tiny/t/cases/form-01.txt
-cpan/HTTP-Tiny/t/cases/form-02.txt
-cpan/HTTP-Tiny/t/cases/form-03.txt
-cpan/HTTP-Tiny/t/cases/form-04.txt
-cpan/HTTP-Tiny/t/cases/form-05.txt
-cpan/HTTP-Tiny/t/cases/get-01.txt
-cpan/HTTP-Tiny/t/cases/get-02.txt
-cpan/HTTP-Tiny/t/cases/get-03.txt
-cpan/HTTP-Tiny/t/cases/get-04.txt
-cpan/HTTP-Tiny/t/cases/get-05.txt
-cpan/HTTP-Tiny/t/cases/get-06.txt
-cpan/HTTP-Tiny/t/cases/get-07.txt
-cpan/HTTP-Tiny/t/cases/get-08.txt
-cpan/HTTP-Tiny/t/cases/get-09.txt
-cpan/HTTP-Tiny/t/cases/get-10.txt
-cpan/HTTP-Tiny/t/cases/get-11.txt
-cpan/HTTP-Tiny/t/cases/get-12.txt
-cpan/HTTP-Tiny/t/cases/get-13.txt
-cpan/HTTP-Tiny/t/cases/get-14.txt
-cpan/HTTP-Tiny/t/cases/get-15.txt
-cpan/HTTP-Tiny/t/cases/get-16.txt
-cpan/HTTP-Tiny/t/cases/get-17.txt
-cpan/HTTP-Tiny/t/cases/get-18.txt
-cpan/HTTP-Tiny/t/cases/get-19.txt
-cpan/HTTP-Tiny/t/cases/get-20.txt
-cpan/HTTP-Tiny/t/cases/get-21.txt
-cpan/HTTP-Tiny/t/cases/head-01.txt
-cpan/HTTP-Tiny/t/cases/keepalive-01.txt
-cpan/HTTP-Tiny/t/cases/keepalive-02.txt
-cpan/HTTP-Tiny/t/cases/keepalive-03.txt
-cpan/HTTP-Tiny/t/cases/keepalive-04.txt
-cpan/HTTP-Tiny/t/cases/keepalive-05.txt
-cpan/HTTP-Tiny/t/cases/mirror-01.txt
-cpan/HTTP-Tiny/t/cases/mirror-02.txt
-cpan/HTTP-Tiny/t/cases/mirror-03.txt
-cpan/HTTP-Tiny/t/cases/mirror-04.txt
-cpan/HTTP-Tiny/t/cases/mirror-05.txt
-cpan/HTTP-Tiny/t/cases/post-01.txt
-cpan/HTTP-Tiny/t/cases/proxy-auth-01.txt
-cpan/HTTP-Tiny/t/cases/put-01.txt
-cpan/HTTP-Tiny/t/cases/put-02.txt
-cpan/HTTP-Tiny/t/cases/put-03.txt
-cpan/HTTP-Tiny/t/cases/put-04.txt
-cpan/HTTP-Tiny/t/cases/put-05.txt
-cpan/HTTP-Tiny/t/cases/redirect-01.txt
-cpan/HTTP-Tiny/t/cases/redirect-02.txt
-cpan/HTTP-Tiny/t/cases/redirect-03.txt
-cpan/HTTP-Tiny/t/cases/redirect-04.txt
-cpan/HTTP-Tiny/t/cases/redirect-05.txt
-cpan/HTTP-Tiny/t/cases/redirect-06.txt
-cpan/HTTP-Tiny/t/cases/redirect-07.txt
-cpan/HTTP-Tiny/t/cases/redirect-08.txt
-cpan/HTTP-Tiny/t/cases/redirect-09.txt
cpan/HTTP-Tiny/t/SimpleCookieJar.pm
cpan/HTTP-Tiny/t/Util.pm
cpan/IO-Compress/bin/zipdetails IO::Compress
cpan/Test-Harness/t/yamlish.t Test::Harness test
cpan/Test-Harness/t/yamlish-writer.t Test::Harness test
cpan/Test/lib/Test.pm A simple framework for writing test scripts
-cpan/Test-Simple/lib/Test/Builder/Module.pm Base class for test modules
-cpan/Test-Simple/lib/Test/Builder.pm For writing new test libraries
-cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm Turn on color in Test::Builder::Tester
-cpan/Test-Simple/lib/Test/Builder/Tester.pm For testing Test::Builder based classes
-cpan/Test-Simple/lib/Test/More.pm More utilities for writing tests
-cpan/Test-Simple/lib/Test/Simple.pm Basic utility for writing tests
-cpan/Test-Simple/lib/Test/Tutorial.pod A tutorial on writing tests
-cpan/Test-Simple/t/00test_harness_check.t Test::Simple test
-cpan/Test-Simple/t/bad_plan.t Test::Builder plan() test
-cpan/Test-Simple/t/bail_out.t Test::Builder BAIL_OUT test
-cpan/Test-Simple/t/BEGIN_require_ok.t Test::More require_ok() testing
-cpan/Test-Simple/t/BEGIN_use_ok.t Test::More use_ok() testing
-cpan/Test-Simple/t/buffer.t Test::Builder buffering test
-cpan/Test-Simple/t/Builder/Builder.t Test::Builder tests
-cpan/Test-Simple/t/Builder/carp.t Test::Builder test
-cpan/Test-Simple/t/Builder/create.t Test::Builder test
-cpan/Test-Simple/t/Builder/current_test.t Test::Builder tests
-cpan/Test-Simple/t/Builder/current_test_without_plan.t Test::Builder tests
-cpan/Test-Simple/t/Builder/details.t Test::Builder tests
-cpan/Test-Simple/t/Builder/done_testing_double.t Test::Builder tests
-cpan/Test-Simple/t/Builder/done_testing_plan_mismatch.t Test::Builder tests
-cpan/Test-Simple/t/Builder/done_testing.t Test::Builder tests
-cpan/Test-Simple/t/Builder/done_testing_with_no_plan.t Test::Builder tests
-cpan/Test-Simple/t/Builder/done_testing_with_number.t Test::Builder tests
-cpan/Test-Simple/t/Builder/done_testing_with_plan.t Test::Builder tests
-cpan/Test-Simple/t/Builder/fork_with_new_stdout.t Test::Builder tests
-cpan/Test-Simple/t/Builder/has_plan2.t Test::Builder tests
-cpan/Test-Simple/t/Builder/has_plan.t Test::Builder tests
-cpan/Test-Simple/t/Builder/is_fh.t Test::Builder tests
-cpan/Test-Simple/t/Builder/is_passing.t Test::Builder tests
-cpan/Test-Simple/t/Builder/maybe_regex.t Test::Builder tests
-cpan/Test-Simple/t/Builder/no_diag.t Test::Builder tests
-cpan/Test-Simple/t/Builder/no_ending.t Test::Builder tests
-cpan/Test-Simple/t/Builder/no_header.t Test::Builder tests
-cpan/Test-Simple/t/Builder/no_plan_at_all.t Test::Builder tests
-cpan/Test-Simple/t/Builder/ok_obj.t Test::Builder tests
-cpan/Test-Simple/t/Builder/output.t Test::Builder tests
-cpan/Test-Simple/t/Builder/reset.t Test::Builder tests
-cpan/Test-Simple/t/Builder/try.t Test::Builder tests
-cpan/Test-Simple/t/c_flag.t Test::Simple test
-cpan/Test-Simple/t/circular_data.t Test::Simple test
-cpan/Test-Simple/t/cmp_ok.t Test::More test
-cpan/Test-Simple/t/dependents.t Test::More test
-cpan/Test-Simple/t/diag.t Test::More diag() test
-cpan/Test-Simple/t/died.t Test::Simple test
-cpan/Test-Simple/t/dont_overwrite_die_handler.t Test::More tests
-cpan/Test-Simple/t/eq_set.t Test::Simple test
-cpan/Test-Simple/t/exit.t Test::Simple test, exit codes
-cpan/Test-Simple/t/explain.t Test::Simple test
-cpan/Test-Simple/t/extra_one.t Test::Simple test
-cpan/Test-Simple/t/extra.t Test::Simple test
-cpan/Test-Simple/t/fail-like.t Test::More test, like() failures
-cpan/Test-Simple/t/fail-more.t Test::More test, tests failing
-cpan/Test-Simple/t/fail_one.t Test::Simple test
-cpan/Test-Simple/t/fail.t Test::Simple test, test failures
-cpan/Test-Simple/t/filehandles.t Test::Simple test, STDOUT can be played with
-cpan/Test-Simple/t/fork.t Test::More fork tests
-cpan/Test-Simple/t/harness_active.t Test::Simple test
-cpan/Test-Simple/t/import.t Test::More test, importing functions
-cpan/Test-Simple/t/is_deeply_dne_bug.t Test::More test
-cpan/Test-Simple/t/is_deeply_fail.t Test::More test, is_deeply()
-cpan/Test-Simple/t/is_deeply_with_threads.t Test::More test
-cpan/Test-Simple/t/lib/Dev/Null.pm Test::More test module
-cpan/Test-Simple/t/lib/Dummy.pm Test::More test module
-cpan/Test-Simple/t/lib/MyOverload.pm Test::More test module
-cpan/Test-Simple/t/lib/NoExporter.pm Test::Simple test module
-cpan/Test-Simple/t/lib/SigDie.pm Test module for Test::More
-cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm Utility module for testing Test::Builder
-cpan/Test-Simple/t/lib/Test/Simple/Catch.pm Utility module for testing Test::Simple
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death_in_eval.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death_with_handler.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/exit.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/extras.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/five_fail.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/last_minute_death.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/missing_done_testing.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/one_fail.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/one_fail_without_plan.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/pre_plan_death.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/require.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/success.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/too_few_fail.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/too_few.plx for exit.t
-cpan/Test-Simple/t/lib/Test/Simple/sample_tests/two_fail.plx for exit.t
-cpan/Test-Simple/t/lib/TieOut.pm Testing library to capture prints
-cpan/Test-Simple/t/missing.t Test::Simple test, missing tests
-cpan/Test-Simple/t/More.t Test::More test, basic stuff
-cpan/Test-Simple/t/new_ok.t Test::More test
-cpan/Test-Simple/t/no_plan.t Test::Simple test, forgot the plan
-cpan/Test-Simple/t/no_tests.t Test::More test
-cpan/Test-Simple/t/note.t Test::More test
-cpan/Test-Simple/t/overload.t Test::Simple test
-cpan/Test-Simple/t/overload_threads.t Test::Simple test
-cpan/Test-Simple/t/plan_bad.t Test::Simple test
-cpan/Test-Simple/t/plan_is_noplan.t Test::Simple test, no_plan
-cpan/Test-Simple/t/plan_no_plan.t Test::More test, plan() w/no_plan
-cpan/Test-Simple/t/plan_shouldnt_import.t Test::Simple test
-cpan/Test-Simple/t/plan_skip_all.t Test::More test, plan() w/skip_all
-cpan/Test-Simple/t/plan.t Test::More test, plan()
-cpan/Test-Simple/t/require_ok.t Test::Simple test
-cpan/Test-Simple/t/Simple/load.t Test::Builder tests
-cpan/Test-Simple/t/simple.t Test::Simple test, basic stuff
-cpan/Test-Simple/t/skipall.t Test::More test, skip all tests
-cpan/Test-Simple/t/skip.t Test::More test, SKIP tests
-cpan/Test-Simple/t/subtest/args.t Test::More test
-cpan/Test-Simple/t/subtest/bail_out.t Test::More test
-cpan/Test-Simple/t/subtest/basic.t Test::More test
-cpan/Test-Simple/t/subtest/die.t Test::More test
-cpan/Test-Simple/t/subtest/do.t Test::More test
-cpan/Test-Simple/t/subtest/exceptions.t Test::More test
-cpan/Test-Simple/t/subtest/for_do_t.test Test::More test
-cpan/Test-Simple/t/subtest/fork.t Test::Builder tests
-cpan/Test-Simple/t/subtest/implicit_done.t Test::Builder tests
-cpan/Test-Simple/t/subtest/line_numbers.t Test::Builder tests
-cpan/Test-Simple/t/subtest/plan.t Test::Builder tests
-cpan/Test-Simple/t/subtest/predicate.t Test::Builder tests
-cpan/Test-Simple/t/subtest/singleton.t Test::More test
-cpan/Test-Simple/t/subtest/threads.t Test::More test
-cpan/Test-Simple/t/subtest/todo.t Test::Builder tests
-cpan/Test-Simple/t/subtest/wstat.t Test::More test
-cpan/Test-Simple/t/tbm_doesnt_set_exported_to.t Test::Builder::Module test
-cpan/Test-Simple/t/Tester/tbt_01basic.t Test::Builder::Tester test
-cpan/Test-Simple/t/Tester/tbt_02fhrestore.t Test::Builder::Tester test
-cpan/Test-Simple/t/Tester/tbt_03die.t Test::Builder::Tester test
-cpan/Test-Simple/t/Tester/tbt_04line_num.t Test::Builder::Tester test
-cpan/Test-Simple/t/Tester/tbt_05faildiag.t Test::Builder::Tester test
-cpan/Test-Simple/t/Tester/tbt_06errormess.t Test::Builder::Tester test
-cpan/Test-Simple/t/Tester/tbt_07args.t Test::Builder::Tester test
-cpan/Test-Simple/t/Tester/tbt_08subtest.t Test::Builder::Tester test
-cpan/Test-Simple/t/Tester/tbt_09do_script.pl Test::Builder::Tester test
-cpan/Test-Simple/t/Tester/tbt_09do.t Test::Builder::Tester test
-cpan/Test-Simple/t/threads.t Test::Builder thread-safe checks
-cpan/Test-Simple/t/thread_taint.t Test::Simple test
-cpan/Test-Simple/t/todo.t Test::More test, TODO tests
-cpan/Test-Simple/t/undef.t Test::More test, undefs don't cause warnings
-cpan/Test-Simple/t/useing.t Test::More test, compile test
-cpan/Test-Simple/t/use_ok.t Test::More test, use_ok()
-cpan/Test-Simple/t/utf8.t Test::More test
-cpan/Test-Simple/t/versions.t Test::More test
+cpan/Test-Simple/lib/ok.pm Test::Simple library
+cpan/Test-Simple/lib/Test/Builder/Module.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Builder.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Builder/Tester.pm Test::Simple module
+cpan/Test-Simple/lib/Test/FAQ.pod Test::Simple module
+cpan/Test-Simple/lib/Test/More/DeepCheck.pm Test::Simple module
+cpan/Test-Simple/lib/Test/More/DeepCheck/Strict.pm Test::Simple module
+cpan/Test-Simple/lib/Test/More/DeepCheck/Tolerant.pm Test::Simple module
+cpan/Test-Simple/lib/Test/More.pm Test::Simple module
+cpan/Test-Simple/lib/Test/More/Tools.pm Test::Simple module
+cpan/Test-Simple/lib/Test/MostlyLike.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Simple.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Architecture.pod Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/ArrayBase/Meta.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/ArrayBase.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Carp.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Context.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Event/Bail.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Event/Child.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Event/Diag.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Event/Finish.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Event/Note.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Event/Plan.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Event.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/ExitMagic/Context.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/ExitMagic.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Exporter/Meta.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Exporter.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/IOSets.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Meta.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/PackageUtil.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Tester/Checks/Event.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Tester/Checks.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Tester/Events/Event.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Tester/Events.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Tester/Grab.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Tester.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Threads.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Toolset.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Stream/Util.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Tester/Capture.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Tester.pm Test::Simple module
+cpan/Test-Simple/lib/Test/Tutorial.pod Test::Simple documentation
+cpan/Test-Simple/lib/Test/Tutorial/WritingTests.pod Test::Simple documentation
+cpan/Test-Simple/lib/Test/Tutorial/WritingTools.pod Test::Simple documentation
+cpan/Test-Simple/lib/Test/use/ok.pm Test::Simple library
+cpan/Test-Simple/t/Behavior/388-threadedsubtest.load Test::Simple Test
+cpan/Test-Simple/t/Behavior/388-threadedsubtest.t Test::Simple test
+cpan/Test-Simple/t/Behavior/478-cmp_ok_hash.t Test::Simple test
+cpan/Test-Simple/t/Behavior/490-inherit_exporter.t Test::Simple test
+cpan/Test-Simple/t/Behavior/cmp_ok_xor.t Test::Simple Test
+cpan/Test-Simple/t/Behavior/encoding_test.t Test::Simple Test
+cpan/Test-Simple/t/Behavior/fork_new_end.t Test::Simple Test
+cpan/Test-Simple/t/Behavior/MonkeyPatching_diag.t Test::Simple Test
+cpan/Test-Simple/t/Behavior/MonkeyPatching_done_testing.t Test::Simple Test
+cpan/Test-Simple/t/Behavior/MonkeyPatching_note.t Test::Simple Test
+cpan/Test-Simple/t/Behavior/MonkeyPatching_ok.t Test::Simple Test
+cpan/Test-Simple/t/Behavior/MonkeyPatching_plan.t Test::Simple Test
+cpan/Test-Simple/t/Behavior/Munge.t Test::Simple Test
+cpan/Test-Simple/t/Behavior/NotTB15.t Test::Simple Test
+cpan/Test-Simple/t/Behavior/skip_all_in_subtest.load Test::Simple Test
+cpan/Test-Simple/t/Behavior/skip_all_in_subtest.t Test::Simple Test
+cpan/Test-Simple/t/Behavior/Tester2_subtest.t Test::Simple Test
+cpan/Test-Simple/t/Behavior/threads_with_taint_mode.t Test::Simple Test
+cpan/Test-Simple/t/Behavior/todo.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/bad_plan.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/bail_out.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/BEGIN_require_ok.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/BEGIN_use_ok.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/buffer.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/Builder.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/carp.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/create.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/current_test.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/current_test_without_plan.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/details.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/done_testing_double.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/done_testing_plan_mismatch.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/done_testing.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/done_testing_with_no_plan.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/done_testing_with_number.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/done_testing_with_plan.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/fork_with_new_stdout.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/has_plan2.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/has_plan.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/is_fh.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/is_passing.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/maybe_regex.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/no_diag.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/no_ending.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/no_header.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/no_plan_at_all.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/ok_obj.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/output.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/reset_outputs.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Builder/reset.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/c_flag.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/circular_data.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/cmp_ok.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/dependents.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/diag.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/died.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/dont_overwrite_die_handler.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/eq_set.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/exit.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/explain.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/extra_one.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/extra.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/fail-like.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/fail-more.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/fail_one.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/fail.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/filehandles.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/fork_in_subtest.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/fork.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/harness_active.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/import.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/is_deeply_dne_bug.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/is_deeply_fail.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/is_deeply_with_threads.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/missing.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/More.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/new_ok.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/no_plan.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/no_tests.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/note.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/overload.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/overload_threads.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/PerlIO.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/plan_bad.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/plan_is_noplan.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/plan_no_plan.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/plan_shouldnt_import.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/plan_skip_all.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/plan.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/pod.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/require_ok.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/ribasushi_diag.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/ribasushi_threads2.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/ribasushi_threads.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Simple/load.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/simple.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/skipall.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/skip.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/strays.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/args.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/bail_out.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/basic.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/die.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/do.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/exceptions.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/for_do_t.test Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/fork.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/implicit_done.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/line_numbers.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/plan.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/predicate.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/singleton.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/threads.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/todo.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/subtest/wstat.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/tbm_doesnt_set_exported_to.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Tester/tbt_01basic.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Tester/tbt_02fhrestore.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Tester/tbt_03die.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Tester/tbt_04line_num.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Tester/tbt_05faildiag.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Tester/tbt_06errormess.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Tester/tbt_07args.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Tester/tbt_08subtest.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/Tester/tbt_09do_script.pl Test::Simple Test
+cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/TestTester/auto.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/TestTester/check_tests.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/TestTester/depth.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/TestTester/is_bug.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/TestTester/run_test.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/test_use_ok.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/threads.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/thread_taint.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/todo.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/undef.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/useing.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/use_ok.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/utf8.t Test::Simple Test
+cpan/Test-Simple/t/Legacy/versions.t Test::Simple Test
+cpan/Test-Simple/t/lib/Dev/Null.pm Test::Simple Test
+cpan/Test-Simple/t/lib/Dummy.pm Test::Simple Test
+cpan/Test-Simple/t/lib/MyOverload.pm Test::Simple Test
+cpan/Test-Simple/t/lib/MyTest.pm Test::Simple Test
+cpan/Test-Simple/t/lib/NoExporter.pm Test::Simple Test
+cpan/Test-Simple/t/lib/SigDie.pm Test::Simple Test
+cpan/Test-Simple/t/lib/SmallTest.pm Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/Catch.pm Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death_in_eval.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/death_with_handler.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/exit.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/extras.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/five_fail.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/last_minute_death.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/missing_done_testing.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/one_fail.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/one_fail_without_plan.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/pre_plan_death.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/require.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/success.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/too_few_fail.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/too_few.plx Test::Simple Test
+cpan/Test-Simple/t/lib/Test/Simple/sample_tests/two_fail.plx Test::Simple Test
+cpan/Test-Simple/t/lib/TieOut.pm Test::Simple Test
+cpan/Test-Simple/t/Test-Builder.t Test::Simple Test
+cpan/Test-Simple/t/Test-More-DeepCheck.t Test::Simple Test
+cpan/Test-Simple/t/Test-More.t Test::Simple Test
+cpan/Test-Simple/t/Test-MostlyLike.t Test::Simple Test
+cpan/Test-Simple/t/Test-Simple.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-ArrayBase-Meta.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-ArrayBase.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-Carp.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-Event-Diag.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-Event-Finish.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-Event-Note.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-Event.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-ExitMagic-Context.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-Exporter-Meta.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-Exporter.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-IOSets.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-Meta.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-PackageUtil.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-Tester-Grab.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-Tester.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-Toolset.t Test::Simple Test
+cpan/Test-Simple/t/Test-Stream-Util.t Test::Simple Test
+cpan/Test-Simple/t/Test-Tester-Capture.t Test::Simple Test
+cpan/Test-Simple/t/Test-Tester.t Test::Simple Test
+cpan/Test-Simple/t/Test-use-ok.t Test::Simple Test
+cpan/Test-Simple/t/xt/dependents.t Test::Simple Test
cpan/Test/t/05_about_verbose.t See if Test works
cpan/Test/t/fail.t See if Test works
cpan/Test/t/mix.t See if Test works
dist/PathTools/lib/File/Spec/VMS.pm portable operations on VMS file names
dist/PathTools/lib/File/Spec/Win32.pm portable operations on Win32 and NetWare file names
dist/PathTools/Makefile.PL makefile writer for Cwd
+dist/PathTools/t/abs2rel.t See if File::Spec->abs2rel works
dist/PathTools/t/crossplatform.t See if File::Spec works crossplatform
dist/PathTools/t/cwd.t See if Cwd works
dist/PathTools/t/Functions.t See if File::Spec::Functions works
ext/XS-APItest/t/gv_init.t XS::APItest: tests for gv_init and variants
ext/XS-APItest/t/handy.t XS::APItest: tests for handy.h
ext/XS-APItest/t/hash.t XS::APItest: tests for hash related APIs
+ext/XS-APItest/t/join_with_space.t test op_convert_list
ext/XS-APItest/t/keyword_multiline.t test keyword plugin parsing across lines
ext/XS-APItest/t/keyword_plugin.t test keyword plugin mechanism
ext/XS-APItest/t/labelconst.aux auxiliary file for label test
ext/XS-APItest/t/my_cxt.t XS::APItest: test MY_CXT interface
ext/XS-APItest/t/my_exit.t XS::APItest: test my_exit
ext/XS-APItest/t/newCONSTSUB.t XS::APItest: test newCONSTSUB(_flags)
+ext/XS-APItest/t/newDEFSVOP.t XS::APItest: test newDEFSVOP
ext/XS-APItest/t/Null.pm Helper for ./blockhooks.t
ext/XS-APItest/t/op_contextualize.t test op_contextualize() API
ext/XS-APItest/t/op_list.t test OP list construction API
ext/XS-APItest/t/swaplabel.t test recursive descent label parsing
ext/XS-APItest/t/swaptwostmts.t test recursive descent statement parsing
ext/XS-APItest/t/sym-hook.t Test rv2cv hooks for bareword lookup
+ext/XS-APItest/t/synthetic_scope.t Test block_start/block_end/intro_my
ext/XS-APItest/t/temp_lv_sub.t XS::APItest: tests for lvalue subs returning temps
ext/XS-APItest/t/underscore_length.t Test find_rundefsv()
ext/XS-APItest/t/utf16_to_utf8.t Test behaviour of utf16_to_utf8{,reversed}
pod/perl5212delta.pod Perl changes in version 5.21.2
pod/perl5213delta.pod Perl changes in version 5.21.3
pod/perl5214delta.pod Perl changes in version 5.21.4
+pod/perl5215delta.pod Perl changes in version 5.21.5
pod/perl561delta.pod Perl changes in version 5.6.1
pod/perl56delta.pod Perl changes in version 5.6
pod/perl581delta.pod Perl changes in version 5.8.1
t/io/pvbm.t See if PVBMs break IO commands
t/io/read.t See if read works
t/io/say.t See if say works
+t/io/semctl.t See if SysV semaphore semctl works
t/io/sem.t See if SysV semaphores work
t/io/shm.t See if SysV shared memory works
t/io/socket.t See if socket functions work
t/lib/warnings/doop Tests for doop.c for warnings.t
t/lib/warnings/gv Tests for gv.c for warnings.t
t/lib/warnings/hv Tests for hv.c for warnings.t
-t/lib/warnings/irs Tests for $/ for warnings.t
t/lib/warnings/malloc Tests for malloc.c for warnings.t
t/lib/warnings/mg Tests for mg.c for warnings.t
t/lib/warnings/op Tests for op.c for warnings.t
t/op/closure_test.pl Extra file for closure.t
t/op/concat2.t Tests too complex for concat.t
t/op/cond.t See if conditional expressions work
+t/op/const-optree.t Tests for sub(){...} becoming constant
t/op/context.t See if context propagation works
t/op/coreamp.t Test &foo() calls for CORE subs
t/op/coresubs.t Generic tests for CORE subs
t/op/not.t See if not works
t/op/numconvert.t See if accessing fields does not change numeric values
t/op/oct.t See if oct and hex work
-t/op/opt.t Test presence of some op optimisations
t/op/ord.t See if ord works
t/op/or.t See if || works in weird situations
t/op/overload_integer.t See if overload::constant for integer works after "use".
t/op/while.t See if while loops work
t/op/write.t See if write works (formats work)
t/op/yadayada.t See if ... works
+t/perf/benchmarks snippets of benchmarking/profiling code
+t/perf/benchmarks.t test t/perf/benchmarks syntax
+t/perf/opcount.t See if optimised subs have the right op counts
+t/perf/optree.t Test presence of some op optimisations
+t/perf/speed.t See if optimisations are keeping things fast
t/perl.supp Perl valgrind suppressions
t/porting/args_assert.t Check that all PERL_ARGS_ASSERT* macros are used
t/porting/authors.t Check that all authors have been acknowledged
"perl5-porters@perl.org"
],
"dynamic_config" : 1,
- "generated_by" : "CPAN::Meta version 2.142690",
+ "generated_by" : "CPAN::Meta version 2.143240",
"license" : [
"perl_5"
],
"url" : "http://perl5.git.perl.org/"
}
},
- "version" : "5.021005"
+ "version" : "5.021006"
}
- perl5-porters@perl.org
build_requires: {}
dynamic_config: 1
-generated_by: 'CPAN::Meta version 2.142690, CPAN::Meta::Converter version 2.142690'
+generated_by: 'CPAN::Meta version 2.143240, CPAN::Meta::Converter version 2.143240'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
homepage: http://www.perl.org/
license: http://dev.perl.org/licenses/
repository: http://perl5.git.perl.org/
-version: '5.021005'
+version: '5.021006'
ndt_obj = $(obj0) $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
obj = $(ndt_obj) $(DTRACE_O)
-perltoc_pod_prereqs = extra.pods pod/perl5215delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod
+perltoc_pod_prereqs = extra.pods pod/perl5216delta.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
$(PERL_EXE): $& perlmain$(OBJ_EXT) $(LIBPERL) $(static_ext) ext.libs $(PERLEXPORT) write_buildcustomize.pl
-@rm -f miniperl.xok
+!NO!SUBS!
+
+ case $osname in
+ os390) $spitshell >>$Makefile <<'!NO!SUBS!'
+ $(SHRPENV) $(CC) -o perl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(LLIBPERL) $(static_ext) `cat ext.libs` $(libs)
+!NO!SUBS!
+ ;;
+ *) $spitshell >>$Makefile <<'!NO!SUBS!'
$(SHRPENV) $(CC) -o perl $(CLDFLAGS) $(CCDLFLAGS) perlmain$(OBJ_EXT) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+!NO!SUBS!
+ ;;
+ esac
+
+ $spitshell >>$Makefile <<'!NO!SUBS!'
# Microperl. This is just a convenience thing if one happens to
# build also the full Perl and therefore the real big Makefile:
pod/perlmodlib.pod: $(MINIPERL_EXE) pod/perlmodlib.PL MANIFEST
$(MINIPERL) pod/perlmodlib.PL -q
-pod/perl5215delta.pod: pod/perldelta.pod
- $(RMS) pod/perl5215delta.pod
- $(LNS) perldelta.pod pod/perl5215delta.pod
+pod/perl5216delta.pod: pod/perldelta.pod
+ $(RMS) pod/perl5216delta.pod
+ $(LNS) perldelta.pod pod/perl5216delta.pod
extra.pods: $(MINIPERL_EXE)
-@test ! -f extra.pods || rm -f `cat extra.pods`
realclean _realcleaner clobber _clobber \
distclean veryclean _verycleaner
-clean: _tidy _mopup
+clean: realclean
realclean: _realcleaner _mopup
@echo "Note that '$(MAKE) realclean' does not delete config.sh or Policy.sh"
-rm -f $(PERL_EXE) $(MINIPERL_EXE) $(LIBPERL) libperl.* microperl
-rm -f config.arch config.over $(DTRACE_H)
-# Do not 'make _tidy' directly.
-_tidy:
- -cd pod; $(LDLIBPTH) $(MAKE) clean
- -cd utils; $(LDLIBPTH) $(MAKE) clean
- -rm -f lib/Config_git.pl git_version.h
- -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \
- $(MINIPERL) make_ext.pl --target=clean $$x MAKE="$(MAKE)" ; \
- done
-
_cleaner1:
-cd os2; rm -f Makefile
-cd pod; $(LDLIBPTH) $(MAKE) $(CLEAN)
-rmdir lib/autodie/Scope lib/autodie lib/XS lib/Win32API lib/VMS
-rmdir lib/Unicode/Collate/Locale lib/Unicode/Collate/CJK
-rmdir lib/Unicode/Collate lib/Tie/Hash lib/Thread lib/Text
- -rmdir lib/Test/Builder/Tester lib/Test/Builder lib/Test lib/Term
- -rmdir lib/TAP/Parser/YAMLish lib/TAP/Parser/SourceHandler
- -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/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/Test/use lib/Test/Tutorial lib/Test/Tester
+ -rmdir lib/Test/Stream/Tester/Events lib/Test/Stream/Tester/Checks
+ -rmdir lib/Test/Stream/Tester lib/Test/Stream/Exporter
+ -rmdir lib/Test/Stream/ExitMagic lib/Test/Stream/Event
+ -rmdir lib/Test/Stream/ArrayBase lib/Test/Stream
+ -rmdir lib/Test/More/DeepCheck lib/Test/More lib/Test/Builder/Tester
+ -rmdir lib/Test/Builder lib/Test lib/Term lib/TAP/Parser/YAMLish
+ -rmdir lib/TAP/Parser/SourceHandler lib/TAP/Parser/Scheduler
+ -rmdir lib/TAP/Parser/Result lib/TAP/Parser/Iterator lib/TAP/Parser
+ -rmdir lib/TAP/Harness lib/TAP/Formatter/File
+ -rmdir lib/TAP/Formatter/Console lib/TAP/Formatter lib/TAP
+ -rmdir lib/Sys/Syslog lib/Sys lib/Sub lib/Search lib/Scalar
+ -rmdir lib/Pod/Text lib/Pod/Simple lib/Pod/Perldoc lib/PerlIO/via
+ -rmdir lib/PerlIO lib/Perl lib/Parse/CPAN lib/Parse lib/Params
+ -rmdir lib/Net/FTP lib/Module/Load lib/Module/CoreList lib/Module
+ -rmdir lib/Memoize lib/Math/BigInt lib/Math/BigFloat lib/Math lib/MIME
+ -rmdir lib/Locale/Maketext lib/Locale/Codes lib/Locale lib/List/Util
+ -rmdir lib/List lib/JSON/PP lib/JSON lib/IPC lib/IO/Uncompress/Adapter
+ -rmdir lib/IO/Uncompress lib/IO/Socket lib/IO/Compress/Zlib
+ -rmdir lib/IO/Compress/Zip lib/IO/Compress/Gzip lib/IO/Compress/Base
-rmdir lib/IO/Compress/Adapter lib/IO/Compress lib/IO
-rmdir lib/I18N/LangTags lib/I18N lib/Hash/Util lib/Hash lib/HTTP
-rmdir lib/Filter/Util lib/Filter lib/File/Spec lib/ExtUtils/Typemaps
- -rmdir lib/ExtUtils/ParseXS lib/ExtUtils/MakeMaker
- -rmdir lib/ExtUtils/Liblist lib/ExtUtils/Constant lib/ExtUtils/Command
+ -rmdir lib/ExtUtils/ParseXS lib/ExtUtils/MakeMaker/version
+ -rmdir lib/ExtUtils/MakeMaker lib/ExtUtils/Liblist
+ -rmdir 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
@echo "to build lib/Config.pm, or the Unicode data files."
@echo " "
- cd t && (rm -f $(PERL_EXE); $(LNS) ../$(MINIPERL_EXE) $(PERL_EXE)) \
- && $(RUN_PERL) TEST base/*.t comp/*.t cmd/*.t run/*.t io/*.t re/*.t opbasic/*.t op/*.t uni/*.t </dev/tty
+ && $(RUN_PERL) TEST base/*.t comp/*.t cmd/*.t run/*.t \
+ io/*.t re/*.t opbasic/*.t op/*.t uni/*.t perf/*.t \
+ </dev/tty
# Test via harness
# Here comes the CW tools - TO BE FILLED TO BUILD WITH CW -
-MODULE_DESC = "Perl 5.21.5 for NetWare"
+MODULE_DESC = "Perl 5.21.6 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.5
+INST_VER = \5.21.6
#
# Comment this out if you DON'T want your perl installation to have
d_archlib='define'
d_asctime64='undef'
d_asctime_r='undef'
+d_asinh='undef'
+d_atanh='undef'
d_atolf='undef'
d_atoll='undef'
d_attribute_deprecated='undef'
d_c99_variadic_macros='undef'
d_casti32='undef'
d_castneg='define'
+d_cbrt='undef'
d_charvspr='undef'
d_chown='undef'
d_chroot='undef'
d_closedir='define'
d_cmsghdr_s='undef'
d_const='define'
+d_copysign='undef'
d_copysignl='undef'
d_cplusplus='undef'
d_crypt='undef'
d_endservent_r='undef'
d_endspent='undef'
d_eofnblk='define'
+d_erf='undef'
+d_erfc='undef'
d_eunice='undef'
+d_exp2='undef'
+d_expm1='undef'
d_faststdio='undef'
d_fchdir='undef'
d_fchmod='undef'
d_fcntl_can_lock='undef'
d_fd_macros='define'
d_fd_set='define'
+d_fdim='undef'
d_fds_bits='define'
d_fegetround='undef'
d_fgetpos='define'
d_flexfnam='define'
d_flock='define'
d_flockproto='undef'
+d_fma='undef'
+d_fmax='undef'
+d_fmin='undef'
d_fork='undef'
d_fp_class='undef'
d_fp_classify='undef'
d_grpasswd='undef'
d_hasmntopt='undef'
d_htonl='define'
+d_hypot='undef'
+d_ilogb='undef'
d_ilogbl='undef'
d_inc_version_list='undef'
d_index='undef'
d_isinfl='undef'
d_isnan='undef'
d_isnanl='undef'
+d_isnormal='undef'
d_j0='undef'
d_j0l='undef'
d_killpg='undef'
d_lchown='undef'
d_ldbl_dig='define'
d_ldexpl='undef'
+d_lgamma='undef'
+d_lgamma_r='undef'
d_libm_lib_version='undef'
d_link='define'
+d_llrint='undef'
+d_llround='undef'
d_localtime64='undef'
d_localtime_r='undef'
d_localtime_r_needs_tzset='undef'
d_locconv='define'
d_lockf='undef'
+d_log1p='undef'
+d_log2='undef'
+d_logb='undef'
d_longdbl='define'
d_longlong='undef'
+d_lrint='undef'
+d_lround='undef'
d_lseekproto='define'
d_lstat='undef'
d_madvise='undef'
d_msync='undef'
d_munmap='undef'
d_mymalloc='undef'
+d_nan='undef'
d_ndbm_h_uses_prototypes='undef'
+d_nearbyint='undef'
+d_nextafter='undef'
+d_nexttoward='undef'
d_nice='undef'
d_nl_langinfo='undef'
d_nv_preserves_uv='define'
d_readlink='undef'
d_readv='undef'
d_recvmsg='undef'
+d_remainder='undef'
+d_remquo='undef'
d_rename='define'
d_rewinddir='define'
+d_rint='undef'
d_rmdir='define'
+d_round='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='define'
d_sbrkproto='undef'
+d_scalbn='undef'
d_scalbnl='undef'
d_sched_yield='undef'
d_scm_rights='undef'
d_tcsetpgrp='undef'
d_telldir='define'
d_telldirproto='define'
+d_tgamma='undef'
d_time='define'
d_timegm='undef'
d_times='undef'
d_tm_tm_gmtoff='undef'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
+d_trunc='undef'
d_truncate='undef'
d_truncl='undef'
d_ttyname_r='undef'
direntrytype='DIR'
dlext='nlm'
dlsrc='dl_netware.xs'
+doublekind='3'
doublesize='8'
drand01='Perl_drand48()'
drand48_r_proto='0'
* 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.5\\lib\\NetWare-x86-multi-thread" /**/
+#define ARCHLIB "c:\\perl\\5.21.6\\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.5\\bin\\NetWare-x86-multi-thread" /**/
-#define BIN_EXP "c:\\perl\\5.21.5\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN "c:\\perl\\5.21.6\\bin\\NetWare-x86-multi-thread" /**/
+#define BIN_EXP "c:\\perl\\5.21.6\\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.5\\lib\\NetWare-x86-multi-thread" /**/
+#define SITEARCH "c:\\perl\\site\\5.21.6\\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.5\\lib" /**/
+#define SITELIB "c:\\perl\\site\\5.21.6\\lib" /**/
/*#define SITELIB_EXP "" /**/
#define SITELIB_STEM "" /**/
which indicates to the C program that the asctime_r()
routine is available.
+d_asinh (d_asinh.U):
+ This variable conditionally defines the HAS_ASINH symbol, which
+ indicates to the C program that the asinh() routine is available.
+
+d_atanh (d_atanh.U):
+ This variable conditionally defines the HAS_ATANH symbol, which
+ indicates to the C program that the atanh() routine is available.
+
d_atolf (atolf.U):
This variable conditionally defines the HAS_ATOLF symbol, which
indicates to the C program that the atolf() routine is available.
This variable conditionally defines CASTNEG, which indicates
whether the C compiler can cast negative float to unsigned.
+d_cbrt (d_cbrt.U):
+ This variable conditionally defines the HAS_CBRT symbol, which
+ indicates to the C program that the cbrt() routine is available.
+
d_charvspr (d_vprintf.U):
This variable conditionally defines CHARVSPRINTF if this system
has vsprintf returning type (char*). The trend seems to be to
indicates to the C program that the chsize() routine is available
to truncate files. You might need a -lx to get this routine.
+d_copysign (d_copysign.U):
+ This variable conditionally defines the HAS_COPYSIGN symbol, which
+ indicates to the C program that the copysign() routine is available.
+
d_class (d_class.U):
This variable conditionally defines the HAS_CLASS symbol, which
indicates to the C program that the class() routine is available.
This variable conditionally defines EOF_NONBLOCK if EOF can be seen
when reading from a non-blocking I/O source.
+d_erf (d_erf.U):
+ This variable conditionally defines the HAS_ERF symbol, which
+ indicates to the C program that the erf() routine is available.
+
+d_erfc (d_erfc.U):
+ This variable conditionally defines the HAS_ERFC symbol, which
+ indicates to the C program that the erfc() routine is available.
+
d_eunice (Guess.U):
This variable conditionally defines the symbols EUNICE and VAX, which
alerts the C program that it must deal with idiosyncrasies of VMS.
+d_exp2 (d_exp2.U):
+ This variable conditionally defines the HAS_EXP2 symbol, which
+ indicates to the C program that the exp2() routine is available.
+
+d_expm1 (d_expm1.U):
+ This variable conditionally defines the HAS_EXPM1 symbol, which
+ indicates to the C program that the expm1() routine is available.
+
d_faststdio (d_faststdio.U):
This variable conditionally defines the HAS_FAST_STDIO symbol,
which indicates to the C program that the "fast stdio" is available
This variable conditionally defines the FCNTL_CAN_LOCK symbol
and indicates whether file locking with fcntl() works.
+d_fdim (d_fdim.U):
+ This variable conditionally defines the HAS_FDIM symbol, which
+ indicates to the C program that the fdim() routine is available.
+
d_fd_macros (d_fd_set.U):
This variable contains the eventual value of the HAS_FD_MACROS symbol,
which indicates if your C compiler knows about the macros which
a prototype for the flock() function. Otherwise, it is
up to the program to supply one.
+d_fma (d_fma.U):
+ This variable conditionally defines the HAS_FMA symbol, which
+ indicates to the C program that the fma() routine is available.
+
+d_fmax (d_fmax.U):
+ This variable conditionally defines the HAS_FMAX symbol, which
+ indicates to the C program that the fmax() routine is available.
+
+d_fmin (d_fmin.U):
+ This variable conditionally defines the HAS_FMIN symbol, which
+ indicates to the C program that the fmin() routine is available.
+
d_fork (d_fork.U):
This variable conditionally defines the HAS_FORK symbol, which
indicates to the C program that the fork() routine is available.
This variable conditionally defines HAS_HTONL if htonl() and its
friends are available to do network order byte swapping.
+d_hypot (d_hypot.U):
+ This variable conditionally defines HAS_HYPOT if hypot is available
+ for numerically stable hypotenuse function.
+
+d_ilogb (d_ilogb.U):
+ This variable conditionally defines the HAS_ILOGB symbol, which
+ indicates to the C program that the ilogb() routine is available
+ for extracting the exponent of double x as a signed integer.
+
d_ilogbl (d_ilogbl.U):
This variable conditionally defines the HAS_ILOGBL symbol, which
- indicates to the C program that the ilogbl() routine is available.
+ indicates to the C program that the ilogbl() routine is available
+ for extracting the exponent of long double x as a signed integer.
If scalbnl is also present we can emulate frexpl.
d_inc_version_list (inc_version_list.U):
This variable conditionally defines the HAS_LDEXPL symbol, which
indicates to the C program that the ldexpl() routine is available.
+d_lgamma (d_lgamma.U):
+ This variable conditionally defines the HAS_LGAMMA symbol, which
+ indicates to the C program that the lgamma() routine is available
+ for the log gamma function. See also d_tgamma and d_lgamma_r.
+
+d_lgamma_r (d_lgamma_r.U):
+ This variable conditionally defines the HAS_LGAMMA_R symbol, which
+ indicates to the C program that the lgamma() routine is available
+ for the log gamma function, without using the global signgam variable.
+
d_libm_lib_version (d_libm_lib_version.U):
This variable conditionally defines the LIBM_LIB_VERSION symbol,
which indicates to the C program that math.h defines _LIB_VERSION
This variable conditionally defines HAS_LINK if link() is
available to create hard links.
+d_llrint (d_llrint.U):
+ This variable conditionally defines the HAS_LLRINT symbol, which
+ indicates to the C program that the llrint() routine is available
+ to return the long long value closest to (according to the current
+ rounding mode) to x.
+
+d_llround (d_llround.U):
+ This variable conditionally defines the HAS_LLROUND symbol, which
+ indicates to the C program that the llround() routine is available
+ to return the long long value nearest to x.
+
d_localtime64 (d_timefuncs64.U):
This variable conditionally defines the HAS_LOCALTIME64 symbol, which
indicates to the C program that the localtime64 () routine is available.
This variable conditionally defines HAS_LOCKF if lockf() is
available to do file locking.
+d_log1p (d_log1p.U):
+ This variable conditionally defines the HAS_LOG1P symbol, which
+ indicates to the C program that the logp1() routine is available
+ to compute log(1 + x) for values of x close to zero.
+
+d_log2 (d_log2.U):
+ This variable conditionally defines the HAS_LOG2 symbol, which
+ indicates to the C program that the log2() routine is available
+ to compute log base two.
+
+d_logb (d_logb.U):
+ This variable conditionally defines the HAS_LOGB symbol, which
+ indicates to the C program that the logb() routine is available
+ to extract the exponent of x.
+
d_longdbl (d_longdbl.U):
This variable conditionally defines HAS_LONG_DOUBLE if
the long double type is supported.
This variable conditionally defines HAS_LONG_LONG if
the long long type is supported.
+d_lrint (d_lrint.U):
+ This variable conditionally defines the HAS_LRINT symbol, which
+ indicates to the C program that the lrint() routine is available
+ to return the integral value closest to (according to the current
+ rounding mode) to x.
+
+d_lround (d_lround.U):
+ This variable conditionally defines the HAS_LROUND symbol, which
+ indicates to the C program that the lround() routine is available
+ to return the integral value nearest to x.
+
d_lseekproto (d_lseekproto.U):
This variable conditionally defines the HAS_LSEEK_PROTO symbol,
which indicates to the C program that the system provides
of the source want to take special action if MYMALLOC is used.
This may include different sorts of profiling or error detection.
+d_nan (d_nan.U):
+ This variable conditionally defines HAS_NAN if nan() is
+ available to generate NaN.
+
d_ndbm (i_ndbm.U):
This variable conditionally defines the HAS_NDBM symbol, which
indicates that both the ndbm.h include file and an appropriate ndbm
undefined. Consult the different d_*ndbm_h_uses_prototypes variables
to get the same information for alternative ndbm.h include files.
+d_nearbyint (d_nearbyint.U):
+ This variable conditionally defines HAS_NEARBYINT if nearbyint()
+ is available to return the integral value closest to (according to
+ the current rounding mode) to x.
+
+d_nextafter (d_nextafter.U):
+ This variable conditionally defines HAS_NEXTAFTER if nextafter()
+ is available to return the next machine representable double from
+ x in direction y.
+
+d_nexttoward (d_nexttoward.U):
+ This variable conditionally defines HAS_NEXTTOWARD if nexttoward()
+ is available to return the next machine representable long double from
+ x in direction y.
+
d_nice (d_nice.U):
This variable conditionally defines the HAS_NICE symbol, which
indicates to the C program that the nice() routine is available.
This variable conditionally defines the HAS_RECVMSG symbol, which
indicates to the C program that the recvmsg() routine is available.
+d_remainder (d_remainder.U):
+ This variable conditionally defines the HAS_REMAINDER symbol, which
+ indicates to the C program that the remainder() routine is available.
+
+d_remquo (d_remquo.U):
+ This variable conditionally defines the HAS_REMQUO symbol, which
+ indicates to the C program that the remquo() routine is available.
+
d_rename (d_rename.U):
This variable conditionally defines the HAS_RENAME symbol, which
indicates to the C program that the rename() routine is available
This variable conditionally defines HAS_REWINDDIR if rewinddir() is
available.
+d_rint (d_rint.U):
+ This variable conditionally defines the HAS_RINT symbol, which
+ indicates to the C program that the rint() routine is available.
+
d_rmdir (d_rmdir.U):
This variable conditionally defines HAS_RMDIR if rmdir() is
available to remove directories.
+d_round (d_round.U):
+ This variable conditionally defines the HAS_ROUND symbol, which
+ indicates to the C program that the round() routine is available.
+
d_safebcpy (d_safebcpy.U):
This variable conditionally defines the HAS_SAFE_BCOPY symbol if
the bcopy() routine can do overlapping copies. Normally, you
a prototype for the sbrk() function. Otherwise, it is
up to the program to supply one.
+d_scalbn (d_scalbn.U):
+ This variable conditionally defines the HAS_SCALBN symbol, which
+ indicates to the C program that the scalbn() routine is available.
+
d_scalbnl (d_scalbnl.U):
This variable conditionally defines the HAS_SCALBNL symbol, which
indicates to the C program that the scalbnl() routine is available.
a prototype for the telldir() function. Otherwise, it is
up to the program to supply one.
+d_tgamma (d_tgamma.U):
+ This variable conditionally defines the HAS_TGAMMA symbol, which
+ indicates to the C program that the tgamma() routine is available
+ for the gamma function. See also d_lgamma.
+
d_time (d_time.U):
This variable conditionally defines the HAS_TIME symbol, which indicates
that the time() routine exists. The time() routine is normally
This variable conditionally defines HAS_TRUNCATE if truncate() is
available to truncate files.
+d_trunc (d_trunc.U):
+ This variable conditionally defines the HAS_TRUNCL symbol, which
+ indicates to the C program that the trunc() routine is available
+ to round doubles towards zero.
+
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
This variable contains the name of the dynamic loading file that
will be used with the package.
+doublekind (doublekind.U):
+ This variable, if defined, encodes the type of a double:
+ 1 = IEEE 754 32-bit big little endian,
+ 2 = IEEE 754 32-bit big big endian,
+ 3 = IEEE 754 64-bit big little endian,
+ 4 = IEEE 754 64-bit big big endian,
+ 5 = IEEE 754 128-bit big little endian,
+ 6 = IEEE 754 128-bit big big endian,
+ 7 = IEEE 754 64-bit big mixed endian le-be,
+ 8 = IEEE 754 64-bit big mixed endian be-le,
+ -1 = unknown format.
+
doublesize (doublesize.U):
This variable contains the value of the DOUBLESIZE symbol, which
indicates to the C program how many bytes there are in a double.
This variable is defined but not used by Configure.
The value is the empty string and is not useful.
-endgrent_r_proto (d_endgrent_r.U):
+ddgrent_r_proto (d_endgrent_r.U):
This variable encodes the prototype of endgrent_r.
It is zero if d_endgrent_r is undef, and one of the
REENTRANT_PROTO_T_ABC macros of reentr.h if d_endgrent_r
@IGNORABLE = qw(
.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
+ CHANGELOG ChangeLog Changelog CHANGES Changes CONTRIBUTING CONTRIBUTING.mkdn
+ 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 NEWS NOTES perlcritic.rc ppport.h README README.PATCHING
SIGNATURE THANKS TODO Todo VERSION WHATSNEW
);
# Note: When updating CPAN-Meta the META.* files will need to be regenerated
# perl -Icpan/CPAN-Meta/lib Porting/makemeta
'CPAN::Meta' => {
- 'DISTRIBUTION' => 'DAGOLDEN/CPAN-Meta-2.142690.tar.gz',
+ 'DISTRIBUTION' => 'DAGOLDEN/CPAN-Meta-2.143240.tar.gz',
'FILES' => q[cpan/CPAN-Meta],
'EXCLUDED' => [
qw[t/00-report-prereqs.t],
},
'CPAN::Meta::Requirements' => {
- 'DISTRIBUTION' => 'DAGOLDEN/CPAN-Meta-Requirements-2.128.tar.gz',
+ 'DISTRIBUTION' => 'DAGOLDEN/CPAN-Meta-Requirements-2.130.tar.gz',
'FILES' => q[cpan/CPAN-Meta-Requirements],
'EXCLUDED' => [
qw(CONTRIBUTING.mkdn),
},
'Digest::SHA' => {
- 'DISTRIBUTION' => 'MSHELOR/Digest-SHA-5.92.tar.gz',
+ 'DISTRIBUTION' => 'MSHELOR/Digest-SHA-5.93.tar.gz',
'FILES' => q[cpan/Digest-SHA],
'EXCLUDED' => [
qw( t/pod.t
examples/dups
),
],
- # Was hoping to be merged upstream in CPAN RT#96498,
- # but that has been rejected...
- 'CUSTOMIZED' => ['hints/hpux.pl'],
},
'Dumpvalue' => {
},
'Encode' => {
- 'DISTRIBUTION' => 'DANKOGAI/Encode-2.62.tar.gz',
+ 'DISTRIBUTION' => 'DANKOGAI/Encode-2.64.tar.gz',
'FILES' => q[cpan/Encode],
},
},
'experimental' => {
- 'DISTRIBUTION' => 'LEONT/experimental-0.012.tar.gz',
+ 'DISTRIBUTION' => 'LEONT/experimental-0.013.tar.gz',
'FILES' => q[cpan/experimental],
'EXCLUDED' => [
qr{^t/release-.*\.t},
},
'ExtUtils::MakeMaker' => {
- 'DISTRIBUTION' => 'BINGOS/ExtUtils-MakeMaker-6.98.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/ExtUtils-MakeMaker-7.02.tar.gz',
'FILES' => q[cpan/ExtUtils-MakeMaker],
'EXCLUDED' => [
qr{^t/lib/Test/},
'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 ),
+ # Applied upstream
+ q(lib/ExtUtils/MM_Unix.pm),
],
},
'ExtUtils::Manifest' => {
- 'DISTRIBUTION' => 'BINGOS/ExtUtils-Manifest-1.68.tar.gz',
+ 'DISTRIBUTION' => 'ETHER/ExtUtils-Manifest-1.69.tar.gz',
'FILES' => q[cpan/ExtUtils-Manifest],
'EXCLUDED' => [qr(^xt/)],
},
},
'HTTP::Tiny' => {
- 'DISTRIBUTION' => 'DAGOLDEN/HTTP-Tiny-0.050.tar.gz',
+ 'DISTRIBUTION' => 'DAGOLDEN/HTTP-Tiny-0.051.tar.gz',
'FILES' => q[cpan/HTTP-Tiny],
'EXCLUDED' => [
't/00-report-prereqs.t',
},
'Module::CoreList' => {
- 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20141002.tar.gz',
+ 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20141020.tar.gz',
'FILES' => q[dist/Module-CoreList],
},
},
'perlfaq' => {
- 'DISTRIBUTION' => 'LLAP/perlfaq-5.0150045.tar.gz',
+ 'DISTRIBUTION' => 'ETHER/perlfaq-5.0150046.tar.gz',
'FILES' => q[cpan/perlfaq],
'EXCLUDED' => [
qw( t/release-pod-syntax.t
},
'Test::Harness' => {
- 'DISTRIBUTION' => 'LEONT/Test-Harness-3.33.tar.gz',
+ 'DISTRIBUTION' => 'LEONT/Test-Harness-3.34.tar.gz',
'FILES' => q[cpan/Test-Harness],
'EXCLUDED' => [
qr{^examples/},
},
'Test::Simple' => {
- 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.001008.tar.gz',
+ 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.301001_073.tar.gz',
'FILES' => q[cpan/Test-Simple],
'EXCLUDED' => [
qr{^t/xt},
+ qr{^xt},
+ qr{^profiling},
qw( .perlcriticrc
.perltidyrc
examples/indent.pl
examples/subtest.t
- t/00compile.t
- t/pod.t
- t/pod-coverage.t
- t/Builder/reset_outputs.t
- lib/Test/Builder/IO/Scalar.pm
+ t/Legacy/00compile.t
+ t/Legacy/pod.t
),
],
- },
+ 'CUSTOMIZED' => [
+ # Waiting to be merged upstream: see pull request #494
+ qw( t/Legacy/exit.t ),
+ ], },
'Text::Abbrev' => {
'DISTRIBUTION' => 'FLORA/Text-Abbrev-1.02.tar.gz',
ansi2knr=''
aphostname='/bin/hostname'
api_revision='5'
-api_subversion='5'
+api_subversion='6'
api_version='21'
-api_versionstring='5.21.5'
+api_versionstring='5.21.6'
ar='ar'
-archlib='/pro/lib/perl5/5.21.5/i686-linux-64int'
-archlibexp='/pro/lib/perl5/5.21.5/i686-linux-64int'
+archlib='/pro/lib/perl5/5.21.6/i686-linux-64int'
+archlibexp='/pro/lib/perl5/5.21.6/i686-linux-64int'
archname64='64int'
archname='i686-linux-64int'
archobjs=''
d_archlib='define'
d_asctime64='undef'
d_asctime_r='undef'
+d_asinh='undef'
+d_atanh='undef'
d_atolf='undef'
d_atoll='define'
d_attribute_deprecated='define'
d_c99_variadic_macros='define'
d_casti32='undef'
d_castneg='define'
+d_cbrt='undef'
d_charvspr='undef'
d_chown='define'
d_chroot='define'
d_closedir='define'
d_cmsghdr_s='define'
d_const='define'
+d_copysign='undef'
d_copysignl='define'
d_cplusplus='undef'
d_crypt='define'
d_endsent='define'
d_endservent_r='undef'
d_eofnblk='define'
+d_erf='undef'
+d_erfc='undef'
d_eunice='undef'
+d_exp2='undef'
+d_expm1='undef'
d_faststdio='define'
d_fchdir='define'
d_fchmod='define'
d_fcntl_can_lock='define'
d_fd_macros='define'
d_fd_set='define'
+d_fdim='undef'
d_fds_bits='undef'
d_fegetround='undef'
d_fgetpos='define'
d_flexfnam='define'
d_flock='define'
d_flockproto='define'
+d_fma='undef'
+d_fmax='undef'
+d_fmin='undef'
d_fork='define'
d_fp_class='undef'
d_fp_classify='undef'
d_grpasswd='define'
d_hasmntopt='define'
d_htonl='define'
+d_hypot='undef'
+d_ilogb='undef'
d_ilogbl='define'
d_inc_version_list='undef'
d_index='undef'
d_isinfl='undef'
d_isnan='define'
d_isnanl='define'
+d_isnormal='undef'
d_j0='undef'
d_j0l='undef'
d_killpg='define'
d_lchown='define'
d_ldbl_dig='define'
d_ldexpl='define'
+d_lgamma='undef'
+d_lgamma_r='undef'
d_libm_lib_version='define'
d_libname_unique='undef'
d_link='define'
+d_llrint='undef'
+d_llround='undef'
d_localtime64='undef'
d_localtime_r='undef'
d_localtime_r_needs_tzset='undef'
d_locconv='define'
d_lockf='define'
+d_log1p='undef'
+d_log2='undef'
+d_logb='undef'
d_longdbl='define'
d_longlong='define'
+d_lrint='undef'
+d_lround='undef'
d_lseekproto='define'
d_lstat='define'
d_madvise='define'
d_msync='define'
d_munmap='define'
d_mymalloc='undef'
+d_nan='undef'
d_ndbm='define'
d_ndbm_h_uses_prototypes='define'
+d_nearbyint='undef'
+d_nextafter='undef'
+d_nexttoward='undef'
d_nice='define'
d_nl_langinfo='define'
d_nv_preserves_uv='undef'
d_readlink='define'
d_readv='define'
d_recvmsg='define'
+d_remainder='undef'
+d_remquo='undef'
d_rename='define'
d_rewinddir='define'
+d_rint='undef'
d_rmdir='define'
+d_round='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='define'
d_sbrkproto='define'
+d_scalbn='undef'
d_scalbnl='define'
d_sched_yield='define'
d_scm_rights='define'
d_tcsetpgrp='define'
d_telldir='define'
d_telldirproto='define'
+d_tgamma='undef'
d_time='define'
d_timegm='define'
d_times='define'
d_tm_tm_gmtoff='define'
d_tm_tm_zone='define'
d_tmpnam_r='undef'
+d_trunc='undef'
d_truncate='define'
d_truncl='undef'
d_ttyname_r='undef'
direntrytype='struct dirent'
dlext='so'
dlsrc='dl_dlopen.xs'
+doublekind='3'
doublesize='8'
drand01='Perl_drand48()'
drand48_r_proto='0'
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.5/i686-linux-64int'
+installarchlib='/pro/lib/perl5/5.21.6/i686-linux-64int'
installbin='/pro/bin'
installhtml1dir=''
installhtml3dir=''
installman3dir='/pro/local/man/man3'
installprefix='/pro'
installprefixexp='/pro'
-installprivlib='/pro/lib/perl5/5.21.5'
+installprivlib='/pro/lib/perl5/5.21.6'
installscript='/pro/bin'
-installsitearch='/pro/lib/perl5/site_perl/5.21.5/i686-linux-64int'
+installsitearch='/pro/lib/perl5/site_perl/5.21.6/i686-linux-64int'
installsitebin='/pro/bin'
installsitehtml1dir=''
installsitehtml3dir=''
-installsitelib='/pro/lib/perl5/site_perl/5.21.5'
+installsitelib='/pro/lib/perl5/site_perl/5.21.6'
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.5'
+perlpath='/pro/bin/perl5.21.6'
pg='pg'
phostname='hostname'
pidtype='pid_t'
pr=''
prefix='/pro'
prefixexp='/pro'
-privlib='/pro/lib/perl5/5.21.5'
-privlibexp='/pro/lib/perl5/5.21.5'
+privlib='/pro/lib/perl5/5.21.6'
+privlibexp='/pro/lib/perl5/5.21.6'
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.5/i686-linux-64int'
-sitearchexp='/pro/lib/perl5/site_perl/5.21.5/i686-linux-64int'
+sitearch='/pro/lib/perl5/site_perl/5.21.6/i686-linux-64int'
+sitearchexp='/pro/lib/perl5/site_perl/5.21.6/i686-linux-64int'
sitebin='/pro/bin'
sitebinexp='/pro/bin'
sitehtml1dir=''
sitehtml1direxp=''
sitehtml3dir=''
sitehtml3direxp=''
-sitelib='/pro/lib/perl5/site_perl/5.21.5'
+sitelib='/pro/lib/perl5/site_perl/5.21.6'
sitelib_stem='/pro/lib/perl5/site_perl'
-sitelibexp='/pro/lib/perl5/site_perl/5.21.5'
+sitelibexp='/pro/lib/perl5/site_perl/5.21.6'
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.5'
+startperl='#!/pro/bin/perl5.21.6'
startsh='#!/bin/sh'
static_ext=' '
stdchar='char'
strerror_r_proto='0'
strings='/usr/include/string.h'
submit=''
-subversion='5'
+subversion='6'
sysman='/usr/share/man/man1'
sysroot=''
tail=''
vendorprefixexp=''
vendorscript=''
vendorscriptexp=''
-version='5.21.5'
-version_patchlevel_string='version 21 subversion 5'
+version='5.21.6'
+version_patchlevel_string='version 21 subversion 6'
versiononly='define'
vi=''
xlibpth='/usr/lib/386 /lib/386'
zip='zip'
PERL_REVISION=5
PERL_VERSION=21
-PERL_SUBVERSION=5
+PERL_SUBVERSION=6
PERL_API_REVISION=5
PERL_API_VERSION=21
-PERL_API_SUBVERSION=5
+PERL_API_SUBVERSION=6
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.5/i686-linux-64int-ld" /**/
-#define ARCHLIB_EXP "/pro/lib/perl5/5.21.5/i686-linux-64int-ld" /**/
+#define ARCHLIB "/pro/lib/perl5/5.21.6/i686-linux-64int-ld" /**/
+#define ARCHLIB_EXP "/pro/lib/perl5/5.21.6/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.5" /**/
-#define PRIVLIB_EXP "/pro/lib/perl5/5.21.5" /**/
+#define PRIVLIB "/pro/lib/perl5/5.21.6" /**/
+#define PRIVLIB_EXP "/pro/lib/perl5/5.21.6" /**/
/* 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.5/i686-linux-64int-ld" /**/
-#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.21.5/i686-linux-64int-ld" /**/
+#define SITEARCH "/pro/lib/perl5/site_perl/5.21.6/i686-linux-64int-ld" /**/
+#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.21.6/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.5" /**/
-#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.21.5" /**/
+#define SITELIB "/pro/lib/perl5/site_perl/5.21.6" /**/
+#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.21.6" /**/
#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.5" /**/
+#define STARTPERL "#!/pro/bin/perl5.21.6" /**/
/* HAS_STDIO_STREAM_ARRAY:
* This symbol, if defined, tells that there is an array
=head1 EPIGRAPHS
+=head2 v5.21.5 - Friso Wiegersma (text), Jean Ferrat (music), Wim Sonneveld (performer), Het Dorp
+
+L<Announced on 2014-10-20 by Abigail|http://www.nntp.perl.org/group/perl.perl5.porters/2014/10/msg221399.html>
+
+ Het Dorp
+
+ Thuis heb ik nog een ansichtkaart
+ waarop een kerk, een kar met paard,
+ een slagerij J. van der Ven.
+ Een kroeg, een juffrouw op de fiets
+ het zegt u hoogstwaarschijnlijk niets,
+ maar 't is waar ik geboren ben.
+ Dit dorp, ik weet nog hoe het was,
+ de boerenkind'ren in de klas,
+ een kar die ratelt op de keien,
+ het raadhuis met een pomp ervoor,
+ een zandweg tussen koren door,
+ het vee, de boerderijen.
+
+ En langs het tuinpad van m'n vader
+ zag ik de hoge bomen staan.
+ Ik was een kind en wist niet beter,
+ dan dat dat nooit voorbij zou gaan.
+
+ Wat leefden ze eenvoudig toen
+ in simp'le huizen tussen groen
+ met boerenbloemen en een heg.
+ Maar blijkbaar leefden ze verkeerd,
+ het dorp is gemoderniseerd
+ en nu zijn ze op de goeie weg.
+ Want ziet, hoe rijk het leven is,
+ ze zien de televisiequiz
+ en wonen in betonnen dozen,
+ met flink veel glas, dan kun je zien
+ hoe of het bankstel staat bij Mien
+ en d'r dressoir met plastic rozen.
+
+ En langs het tuinpad van m'n vader
+ zag ik de hoge bomen staan.
+ Ik was een kind en wist niet beter,
+ dan dat dat nooit voorbij zou gaan.
+
+ De dorpsjeugd klit wat bij elkaar
+ in minirok en beatle-haar
+ en joelt wat mee met beat-muziek.
+ Ik weet wel, het is hun goeie recht,
+ de nieuwe tijd, net wat u zegt,
+ maar het maakt me wat melancholiek.
+ Ik heb hun vaders nog gekend
+ ze kochten zoethout voor een cent
+ ik zag hun moeders touwtjespringen.
+ Dat dorp van toen, het is voorbij,
+ dit is al wat er bleef voor mij:
+ een ansicht en herinneringen.
+
+ Toen ik langs het tuinpad van m'n vader
+ de hoge bomen nog zag staan.
+ Ik was een kind, hoe kon ik weten
+ dat dat voorgoed voorbij zou gaan.
+
=head2 v5.21.4 - Edgar Allan Poe, The Narrative of Arthur Gordon Pym of Nantucket
L<Announced on 2014-09-20 by Steve Hay|http://www.nntp.perl.org/group/perl.perl5.porters/2014/09/msg220267.html>
XXX Generate this with:
- perl Porting/acknowledgements.pl v5.21.5..HEAD
+ perl Porting/acknowledgements.pl v5.21.6..HEAD
=head1 Reporting Bugs
XXX Generate this with:
- perl Porting/acknowledgements.pl v5.21.5..HEAD
+ perl Porting/acknowledgements.pl v5.21.6..HEAD
=head1 Reporting Bugs
GNU configure --options. It's not always obvious exactly what is
intended, but this merits investigation.
-=item make clean
-
-Currently, B<make clean> isn't all that useful, though
-B<make realclean> and B<make distclean> are. This needs a bit of
-thought and documentation before it gets cleaned up.
-
=item Try gcc if cc fails
Currently, we just give up.
This might not cause any new changes.
+You may also need to regen opcodes:
+
+ $ ./perl -Ilib regen/opcode.pl
+
+You may have to add stub entries in C<%Module::CoreList::version>,
+C<%Module::CoreList::deprecated> and C<%Module::CoreList::Utils::delta>.
+If so, you must up their version numbers as well.
+
Test your changes:
$ git clean -xdf # careful if you don't have local files to keep!
of Perl. Dates with two or more question marks will only be releases if
deemed necessary by the Pumpking.
+=head2 Perl 5.22
+
+Code freezes (which happen in the 5.21.X series)
+
+ 2015-01-20 5.21.8 Contentious changes freeze
+ 2015-02-20 5.21.9 User-visible changes freeze
+ 2015-03-20 5.21.10 Full code freeze
+ 2015-05-20 5.22.0 Stable release!
+
=head2 Perl 5.20
2014-05-27 5.20.0 ✓ Ricardo Signes
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-??-?? 5.18.3 ??
+ 2014-10-01 5.18.3 ✓ Ricardo Signes
+ 2014-10-01 5.18.4 ✓ Ricardo Signes
+ 2015-??-?? 5.18.5 ??
=head1 DEVELOPMENT RELEASE SCHEDULE
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 Abigail
+ 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
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.5.
+options would be nice for perl 5.21.6.
=head2 Profile Perl - am I hot or not?
=head1 Big projects
Tasks that will get your name mentioned in the description of the "Highlights
-of 5.21.5"
+of 5.21.6"
=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.5/BePC-haiku/CORE/libperl.so .
+ cd /boot/common/lib; ln -s perl5/5.21.6/BePC-haiku/CORE/libperl.so .
-Replace C<5.21.5> with your respective version of Perl.
+Replace C<5.21.6> 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.5.tar.gz
- tar -xzf perl-5.21.5.tar.gz
- cd perl-5.21.5
+ curl -O http://www.cpan.org/src/perl-5.21.6.tar.gz
+ tar -xzf perl-5.21.6.tar.gz
+ cd perl-5.21.6
./Configure -des -Dprefix=/usr/local/
make
make test
=head1 DESCRIPTION
-The latest Perl release (5.21.5 as of this writing) builds without changes
+The latest Perl release (5.21.6 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.5/
+ unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.21.6/
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^.5.tar
+ vmstar -xvf perl-5^.21^.6.tar
Then set default to the top-level source directory like so:
- set default [.perl-5^.21^.5]
+ set default [.perl-5^.21^.6]
and proceed with configuration as described in the next section.
#else
# define dXSARGS \
dSP; dAXMARK; dITEMS
+/* These 3 macros are replacements for dXSARGS macro only in bootstrap.
+ They factor out common code in every BOOT XSUB. Computation of vars mark
+ and items will optimize away in most BOOT functions. Var ax can never be
+ optimized away since BOOT must return &PL_sv_yes by default from xsubpp.
+ Note these macros are not drop in replacements for dXSARGS since they set
+ PL_xsubfilename. */
+# define dXSBOOTARGSXSAPIVERCHK \
+ I32 ax = XS_BOTHVERSION_SETXSUBFN_POPMARK_BOOTCHECK; \
+ SV **mark = PL_stack_base + ax; dSP; dITEMS
+# define dXSBOOTARGSAPIVERCHK \
+ I32 ax = XS_APIVERSION_SETXSUBFN_POPMARK_BOOTCHECK; \
+ SV **mark = PL_stack_base + ax; dSP; dITEMS
+/* dXSBOOTARGSNOVERCHK has no API in xsubpp to choose it so do
+#undef dXSBOOTARGSXSAPIVERCHK
+#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK */
+# define dXSBOOTARGSNOVERCHK \
+ I32 ax = XS_SETXSUBFN_POPMARK; \
+ SV **mark = PL_stack_base + ax; dSP; dITEMS
#endif
#define dXSTARG SV * const targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
#ifdef XS_VERSION
# define XS_VERSION_BOOTCHECK \
- Perl_xs_version_bootcheck(aTHX_ items, ax, STR_WITH_LEN(XS_VERSION))
+ Perl_xs_handshake(HS_KEY(FALSE, FALSE, "", XS_VERSION), HS_CXT, __FILE__, \
+ items, ax, XS_VERSION)
#else
# define XS_VERSION_BOOTCHECK
#endif
#define XS_APIVERSION_BOOTCHECK \
- Perl_xs_apiversion_bootcheck(aTHX_ ST(0), STR_WITH_LEN("v" PERL_API_VERSION_STRING))
+ Perl_xs_handshake(HS_KEY(FALSE, FALSE, "v" PERL_API_VERSION_STRING, ""), \
+ HS_CXT, __FILE__, items, ax, "v" PERL_API_VERSION_STRING)
+/* public API, this is a combination of XS_VERSION_BOOTCHECK and
+ XS_APIVERSION_BOOTCHECK in 1, and is backportable */
+#ifdef XS_VERSION
+# define XS_BOTHVERSION_BOOTCHECK \
+ Perl_xs_handshake(HS_KEY(FALSE, FALSE, "v" PERL_API_VERSION_STRING, XS_VERSION), \
+ HS_CXT, __FILE__, items, ax, "v" PERL_API_VERSION_STRING, XS_VERSION)
+#else
+/* should this be a #error? if you want both checked, you better supply XS_VERSION right? */
+# define XS_BOTHVERSION_BOOTCHECK XS_APIVERSION_BOOTCHECK
+#endif
+
+/* private API */
+#define XS_APIVERSION_POPMARK_BOOTCHECK \
+ Perl_xs_handshake(HS_KEY(FALSE, TRUE, "v" PERL_API_VERSION_STRING, ""), \
+ HS_CXT, __FILE__, "v" PERL_API_VERSION_STRING)
+#ifdef XS_VERSION
+# define XS_BOTHVERSION_POPMARK_BOOTCHECK \
+ Perl_xs_handshake(HS_KEY(FALSE, TRUE, "v" PERL_API_VERSION_STRING, XS_VERSION), \
+ HS_CXT, __FILE__, "v" PERL_API_VERSION_STRING, XS_VERSION)
+#else
+/* should this be a #error? if you want both checked, you better supply XS_VERSION right? */
+# define XS_BOTHVERSION_POPMARK_BOOTCHECK XS_APIVERSION_POPMARK_BOOTCHECK
+#endif
+
+#define XS_APIVERSION_SETXSUBFN_POPMARK_BOOTCHECK \
+ Perl_xs_handshake(HS_KEY(TRUE, TRUE, "v" PERL_API_VERSION_STRING, ""), \
+ HS_CXT, __FILE__, "v" PERL_API_VERSION_STRING)
+#ifdef XS_VERSION
+# define XS_BOTHVERSION_SETXSUBFN_POPMARK_BOOTCHECK \
+ Perl_xs_handshake(HS_KEY(TRUE, TRUE, "v" PERL_API_VERSION_STRING, XS_VERSION),\
+ HS_CXT, __FILE__, "v" PERL_API_VERSION_STRING, XS_VERSION)
+#else
+/* should this be a #error? if you want both checked, you better supply XS_VERSION right? */
+# define XS_BOTHVERSION_SETXSUBFN_POPMARK_BOOTCHECK XS_APIVERSION_SETXSUBFN_POPMARK_BOOTCHECK
+#endif
+
+/* For a normal bootstrap without API or XS version checking.
+ Useful for static XS modules or debugging/testing scenarios.
+ If this macro gets heavily used in the future, it should separated into
+ a separate function independent of Perl_xs_handshake for efficiency */
+#define XS_SETXSUBFN_POPMARK \
+ Perl_xs_handshake(HS_KEY(TRUE, TRUE, "", "") | HSf_NOCHK, HS_CXT, __FILE__)
#ifdef NO_XSLOCKS
# define dXCPT dJMPENV; int rEtV = 0
*/
#$d_munmap HAS_MUNMAP /**/
+/* HAS_NAN:
+ * This symbol, if defined, indicates that the nan routine is
+ * available to generate NaN.
+ */
+#$d_nan HAS_NAN /**/
+
+/* HAS_NEARBYINT:
+ * This symbol, if defined, indicates that the nextafter routine is
+ * available to return the integral value closest to (according to
+ the current rounding mode) to x.
+ */
+#$d_nearbyint HAS_NEARBYINT /**/
+
+/* HAS_NEXTAFTER:
+ * This symbol, if defined, indicates that the nextafter routine is
+ * available to return the next machine representable long double from
+ * x in direction y.
+ */
+#$d_nextafter HAS_NEXTAFTER /**/
+
+/* HAS_NEXTTOWARD:
+ * This symbol, if defined, indicates that the nexttoward routine is
+ * available to return the next machine representable long double from
+ * x in direction y.
+ */
+#$d_nexttoward HAS_NEXTTOWARD /**/
+
/* HAS_NICE:
* This symbol, if defined, indicates that the nice routine is
* available.
*/
#$d_readlink HAS_READLINK /**/
+/* HAS_REMAINDER:
+ * This symbol, if defined, indicates that the remainder routine is available.
+ */
+#$d_remainder HAS_REMAINDER /**/
+
+/* HAS_REMQUO:
+ * This symbol, if defined, indicates that the remquo routine is available.
+ */
+#$d_remquo HAS_REMQUO /**/
+
/* HAS_RENAME:
* This symbol, if defined, indicates that the rename routine is available
* to rename files. Otherwise you should do the unlink(), link(), unlink()
*/
#$d_rename HAS_RENAME /**/
+/* HAS_RINT:
+ * This symbol, if defined, indicates that the rint routine is available
+ * to return the nearest integral value to x as double using the current
+ * rounding mode.
+ */
+#$d_rint HAS_RINT /**/
+
/* HAS_RMDIR:
* This symbol, if defined, indicates that the rmdir routine is
* available to remove directories. Otherwise you should fork off a
*/
#$d_rmdir HAS_RMDIR /**/
+/* HAS_ROUND:
+ * This symbol, if defined, indicates that the round routine is available.
+ */
+#$d_round HAS_ROUND /**/
+
/* HAS_SELECT:
* This symbol, if defined, indicates that the select routine is
* available to select active file descriptors. If the timeout field
*/
#$d_tcsetpgrp HAS_TCSETPGRP /**/
+/* HAS_TGAMMA:
+ * This symbol, if defined, indicates that the lgamma routine is
+ * available to do the gamma function. See also HAS_LGAMMA.
+ */
+#$d_tgamma HAS_TGAMMA /**/
+
/* HAS_TRUNCATE:
* This symbol, if defined, indicates that the truncate routine is
* available to truncate files.
*/
#define DOUBLESIZE $doublesize /**/
+/* DOUBLEKIND:
+ * DOUBLEKIND will be one of
+ * DOUBLE_IS_IEEE_754_32_BIT_LITTLE_ENDIAN
+ * DOUBLE_IS_IEEE_754_32_BIT_BIG_ENDIAN
+ * DOUBLE_IS_IEEE_754_64_BIT_LITTLE_ENDIAN
+ * DOUBLE_IS_IEEE_754_64_BIT_BIG_ENDIAN
+ * DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
+ * DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN
+ * DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE
+ * DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE
+ * DOUBLE_IS_UNKNOWN_FORMAT
+ */
+#define DOUBLEKIND $doublekind /**/
+#define DOUBLE_IS_IEEE_754_32_BIT_LITTLE_ENDIAN 1
+#define DOUBLE_IS_IEEE_754_32_BIT_BIG_ENDIAN 2
+#define DOUBLE_IS_IEEE_754_64_BIT_LITTLE_ENDIAN 3
+#define DOUBLE_IS_IEEE_754_64_BIT_BIG_ENDIAN 4
+#define DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN 5
+#define DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN 6
+#define DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE 7
+#define DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE 8
+#define DOUBLE_IS_UNKNOWN_FORMAT -1
+
/* EBCDIC:
* This symbol, if defined, indicates that this system uses
* EBCDIC encoding.
*/
#$d_acosh HAS_ACOSH /**/
+/* HAS_ASINH:
+ * This symbol, if defined, indicates that the asinh routine is
+ * available to do the inverse hyperbolic sine function.
+ */
+#$d_asinh HAS_ASINH /**/
+
+/* HAS_ATANH:
+ * This symbol, if defined, indicates that the atanh routine is
+ * available to do the inverse hyperbolic tangent function.
+ */
+#$d_atanh HAS_ATANH /**/
+
+/* HAS_CBRT:
+ * This symbol, if defined, indicates that the cbrt routine is
+ * available to do the cubic root function.
+ */
+#$d_cbrt HAS_CBRT /**/
+
+/* HAS_COPYSIGN:
+ * This symbol, if defined, indicates that the copysign routine is
+ * available to do the copysign function.
+ */
+#$d_copysign HAS_COPYSIGN /**/
+
+/* HAS_ERF:
+ * This symbol, if defined, indicates that the erf routine is
+ * available to do the error function.
+ */
+#$d_erf HAS_ERF /**/
+
+/* HAS_ERFC:
+ * This symbol, if defined, indicates that the erfc routine is
+ * available to do the complementary error function.
+ */
+#$d_erfc HAS_ERFC /**/
+
+/* HAS_EXP2:
+ * This symbol, if defined, indicates that the exp2 routine is
+ * available to do the 2**x function.
+ */
+#$d_exp2 HAS_EXP2 /**/
+
+/* HAS_EXPM1:
+ * This symbol, if defined, indicates that the expm1 routine is
+ * available to do the exp(x) - 1 when x is near 1.
+ */
+#$d_expm1 HAS_EXPM1 /**/
+
+/* HAS_FMA:
+ * This symbol, if defined, indicates that the fma routine is
+ * available to do the multiply-add function.
+ */
+#$d_fma HAS_FMA /**/
+
+/* HAS_FDIM:
+ * This symbol, if defined, indicates that the fdim routine is
+ * available to do the positive difference function.
+ */
+#$d_fdim HAS_FDIM /**/
+
+/* HAS_FMAX:
+ * This symbol, if defined, indicates that the fma routine is
+ * available to do the maximum function.
+ */
+#$d_fmax HAS_FMAX /**/
+
+/* HAS_FMIN:
+ * This symbol, if defined, indicates that the fma routine is
+ * available to do the minimum function.
+ */
+#$d_fmin HAS_FMIN /**/
+
/* HAS_AINTL:
* This symbol, if defined, indicates that the aintl routine is
* available. If copysignl is also present we can emulate modfl.
*/
#$d_hasmntopt HAS_HASMNTOPT /**/
+/* HAS_HYPOT:
+ * This symbol, if defined, indicates that the hypot routine is
+ * available to do the hypotenuse function.
+ */
+#$d_hypot HAS_HYPOT /**/
+
+/* HAS_ILOGB:
+ * This symbol, if defined, indicates that the ilogb routine is
+ * available.
+ */
+#$d_ilogb HAS_ILOGB /**/
+
/* HAS_ILOGBL:
* This symbol, if defined, indicates that the ilogbl routine is
* available. If scalbnl is also present we can emulate frexpl.
*/
#$d_isnanl HAS_ISNANL /**/
+/* HAS_ISNORMAL:
+ * This symbol, if defined, indicates that the isnormal routine is
+ * available to check whether a double is normal (non-zero normalized).
+ */
+#$d_isnormal HAS_ISNORMAL /**/
+
/* HAS_J0:
* This symbol, if defined, indicates to the C program that the
* j0() function is available for Bessel functions of the first
*/
#$d_ldbl_dig HAS_LDBL_DIG /* */
+/* HAS_LGAMMA:
+ * This symbol, if defined, indicates that the lgamma routine is
+ * available to do the log gamma function. See also HAS_TGAMMA and
+ * HAS_LGAMMA_R.
+ */
+#$d_lgamma HAS_LGAMMA /**/
+
+/* HAS_LGAMMA_R:
+ * This symbol, if defined, indicates that the lgamma_r routine is
+ * available to do the log gamma function without using the global
+ * signgam variable.
+ */
+#$d_lgamma_r HAS_LGAMMA_R /**/
+
/* LIBM_LIB_VERSION:
* This symbol, if defined, indicates that libm exports _LIB_VERSION
* and that math.h defines the enum to manipulate it.
*/
#$d_libm_lib_version LIBM_LIB_VERSION /**/
+/* HAS_LLRINT:
+ * This symbol, if defined, indicates that the llrint routine is
+ * available to return the closest long long value according to
+ * the current rounding mode.
+ */
+#$d_llrint HAS_LLRINT /**/
+
+/* HAS_LLROUND:
+ * This symbol, if defined, indicates that the llround routine is
+ * available to return the nearest long long value.
+ */
+#$d_llround HAS_LLROUND /**/
+
+/* HAS_LOG1P:
+ * This symbol, if defined, indicates that the lgamma routine is
+ * available to do the log1p function.
+ */
+#$d_log1p HAS_LOG1P /**/
+
+/* HAS_LOG2:
+ * This symbol, if defined, indicates that the lgamma routine is
+ * available to do the log2 function.
+ */
+#$d_log2 HAS_LOG2 /**/
+
+/* HAS_LOGB:
+ * This symbol, if defined, indicates that the lgamma routine is
+ * available to do the logb function.
+ */
+#$d_logb HAS_LOGB /**/
+
+/* HAS_LRINT:
+ * This symbol, if defined, indicates that the lrint routine is
+ * available to return the closest integral value according to
+ * the current rounding mode.
+ */
+#$d_lrint HAS_LRINT /**/
+
+/* HAS_LROUND:
+ * This symbol, if defined, indicates that the lround routine is
+ * available to return the nearest integral value.
+ */
+#$d_lround HAS_LROUND /**/
+
/* HAS_MADVISE:
* This symbol, if defined, indicates that the madvise system call is
* available to map a file into memory.
*/
#$d_sbrkproto HAS_SBRK_PROTO /**/
+/* HAS_SCALBN:
+ * This symbol, if defined, indicates that the scalbn routine is available.
+ */
+#$d_scalbn HAS_SCALBN /**/
+
/* HAS_SCALBNL:
* This symbol, if defined, indicates that the scalbnl routine is
* available. If ilogbl is also present we can emulate frexpl.
*/
#$d_timegm HAS_TIMEGM /**/
+/* HAS_TRUNC:
+ * This symbol, if defined, indicates that the trunc routine is available.
+ */
+#$d_trunc HAS_TRUNC /**/
+
/* HAS_TRUNCL:
* This symbol, if defined, indicates that the truncl routine is
* available. If copysignl is also present we can emulate modfl.
$ goto replace_dash_with_slash
$
$ end_replace_dash_with_slash:
-$
+$!
+$ IF extspec .EQS. "Scalar/List/Utils" THEN extspec = "List/Util"
+$ IF extspec .EQS. "PathTools" THEN extspec = "Cwd"
+$!
$ xxx = xs_extensions
$ gosub may_already_have_extension
$ IF $STATUS .EQ. 1
$!
$ IF useieee .OR. useieee .EQS. "define"
$ THEN
+$ d_acosh = "define"
+$ d_asinh = "define"
+$ d_atanh = "define"
+$ d_cbrt = "define"
+$ d_copysign = "define"
+$ d_erf = "define"
+$ d_erfc = "define"
+$ d_exp2 = "define"
+$ d_expm1 = "define"
+$ d_fdim = "define"
+$ d_fma = "define"
+$ d_fmax = "define"
+$ d_fmin = "define"
+$ d_fp_classify = "define"
+$ d_hypot = "define"
+$ d_ilogb = "define"
$ d_isnan = "define"
$ d_isnanl = "define"
-$ d_fp_classify = "define"
+$ d_isnormal = "define"
$ d_j0 = "define"
-$ d_acosh = "define"
+$ d_lgamma = "define"
+$ d_log1p = "define"
+$ d_log2 = "define"
+$ d_logb = "define"
+$ d_lrint = "define"
+$ d_lround = "define"
+$ d_nearbyint = "define"
+$ d_nextafter = "define"
+$ d_nexttoward = "define"
+$ d_remainder = "define"
+$ d_remquo = "define"
+$ d_rint = "define"
+$ d_tgamma = "define"
+$ d_trunc = "define"
$ d_truncl = "define"
$ ELSE
+$ d_acosh = "undef"
+$ d_asinh = "undef"
+$ d_atanh = "undef"
+$ d_cbrt = "undef"
+$ d_copysign = "undef"
+$ d_erf = "undef"
+$ d_erfc = "undef"
+$ d_exp2 = "undef"
+$ d_expm1 = "undef"
+$ d_fdim = "undef"
+$ d_fma = "undef"
+$ d_fmax = "undef"
+$ d_fmin = "undef"
+$ d_fp_classify = "undef"
+$ d_hypot = "undef"
+$ d_ilogb = "undef"
$ d_isnan = "undef"
$ d_isnanl = "undef"
-$ d_fp_classify = "undef"
+$ d_isnormal = "undef"
$ d_j0 = "undef"
-$ d_acosh = "undef"
+$ d_lgamma = "undef"
+$ d_log1p = "undef"
+$ d_log2 = "undef"
+$ d_logb = "undef"
+$ d_lrint = "undef"
+$ d_lround = "undef"
+$ d_nearbyint = "undef"
+$ d_nextafter = "undef"
+$ d_nexttoward = "undef"
+$ d_remainder = "undef"
+$ d_remquo = "undef"
+$ d_rint = "undef"
+$ d_tgamma = "undef"
+$ d_trunc = "undef"
$ d_truncl = "undef"
$ ENDIF
$!
$ WC "d_alarm='define'"
$ WC "d_archlib='define'"
$ WC "d_asctime64='undef'"
+$ WC "d_asinh='" + d_asinh + "'"
+$ WC "d_atanh='" + d_atanh + "'"
$ WC "d_atolf='" + d_atolf + "'"
$ WC "d_atoll='" + d_atoll + "'"
$ WC "d_attribute_format='" + d_attribut + "'"
$ WC "d_bzero='" + d_bzero + "'"
$ WC "d_casti32='define'"
$ WC "d_castneg='define'"
+$ WC "d_cbrt='" + d_cbrt + "'"
$ WC "d_charvspr='undef'"
$ WC "d_chown='define'"
$ WC "d_chroot='undef'"
$ WC "d_closedir='define'"
$ WC "d_cmsghdr_s='undef'"
$ WC "d_const='define'"
+$ WC "d_copysign='" + d_copysign + "'"
$ WC "d_copysignl='define'"
$ WC "d_cplusplus='" + d_cplusplus + "'"
$ WC "d_crypt='define'"
$ WC "d_endpwent='define'"
$ WC "d_endsent='" + d_endsent + "'"
$ WC "d_eofnblk='undef'"
+$ WC "d_erf='" + d_erf + "'"
+$ WC "d_erfc='" + d_erfc + "'"
$ WC "d_eunice='undef'"
+$ WC "d_exp2='" + d_exp2 + "'"
+$ WC "d_expm1='" + d_expm1 + "'"
$ WC "d_fchmod='undef'"
$ WC "d_fchdir='undef'"
$ WC "d_fchown='undef'"
$ WC "d_fcntl_can_lock='" + d_fcntl_can_lock + "'"
$ WC "d_fd_set='" + d_fd_set + "'"
$ WC "d_fd_macros='define'"
+$ WC "d_fdim='" + d_fdim + "'"
$ WC "d_fds_bits='define'"
$ WC "d_fegetround='undef'"
$ WC "d_fgetpos='define'"
$ WC "d_flexfnam='define'"
$ WC "d_flock='undef'"
$ WC "d_flockproto='undef'"
+$ WC "d_fma='" + d_fma + "'"
+$ WC "d_fmax='" + d_fmax + "'"
+$ WC "d_fmin='" + d_fmin + "'"
$ WC "d_fork='undef'"
$ WC "d_fp_class='undef'"
$ WC "d_fp_classify='" + d_fp_classify + "'"
$ WC "d_grpasswd='undef'"
$ WC "d_hasmntopt='undef'"
$ WC "d_htonl='" + d_htonl + "'"
+$ WC "d_hypot='" + d_hypot + "'"
+$ WC "d_ilogb='" + d_ilogb + "'"
$ WC "d_ilogbl='undef'"
$ WC "d_inc_version_list='undef'"
$ WC "d_index='" + d_index + "'"
$ WC "d_isinfl='undef'"
$ WC "d_isnan='" + d_isnan + "'"
$ WC "d_isnanl='" + d_isnanl + "'"
+$ WC "d_isnormal='" + d_isnormal + "'"
$ WC "d_j0='" + d_j0 + "'"
$ WC "d_j0l='undef'"
$ WC "d_killpg='undef'"
$ WC "d_lchown='" + d_lchown + "'"
$ WC "d_ldbl_dig='define'"
$ WC "d_ldexpl='" + d_ldexpl + "'"
+$ WC "d_lgamma='" + d_lgamma + "'"
$ WC "d_libm_lib_version='undef'"
$ WC "d_link='" + d_link + "'"
+$ WC "d_llrint='undef'"
+$ WC "d_llround='undef'"
$ WC "d_llseek='undef'"
$ WC "d_localtime64='undef'"
$ WC "d_locconv='" + d_locconv + "'"
$ WC "d_lc_monetary_2008='undef'"
$ WC "d_lockf='undef'"
+$ WC "d_log1p='" + d_log1p + "'"
+$ WC "d_log2='" + d_log2 + "'"
+$ WC "d_logb='" + d_logb + "'"
$ WC "d_longdbl='" + d_longdbl + "'"
$ WC "d_longlong='" + d_longlong + "'"
+$ WC "d_lrint='" + d_lrint + "'"
+$ WC "d_lround='" + d_lround + "'"
$ WC "d_lseekproto='define'"
$ WC "d_lstat='" + d_lstat + "'"
$ WC "d_madvise='undef'"
$ WC "d_msync='" + d_msync + "'"
$ WC "d_munmap='" + d_munmap + "'"
$ WC "d_mymalloc='" + d_mymalloc + "'"
+$ WC "d_nan='undef'"
$ WC "d_nanosleep='" + d_nanosleep + "'"
$ WC "d_ndbm='undef'"
$ WC "d_ndbm_h_uses_prototypes='undef'"
+$ WC "d_nearbyint='undef'"
+$ WC "d_nextafter='" + d_nextafter + "'"
+$ WC "d_nexttoward='" + d_nexttoward + "'"
$ WC "d_nice='define'"
$ WC "d_nl_langinfo='" + d_nl_langinfo + "'"
$ WC "d_nv_preserves_uv='" + d_nv_preserves_uv + "'"
$ WC "d_readv='undef'"
$ WC "d_realpath='" + d_realpath + "'"
$ WC "d_recvmsg='undef'"
+$ WC "d_remainder='" + d_remainder + "'"
+$ WC "d_remquo='" + d_remquo + "'"
$ WC "d_rename='define'"
$ WC "d_rewinddir='define'"
+$ WC "d_rint='" + d_rint + "'"
$ WC "d_rmdir='define'"
+$ WC "d_round='undef'"
$ WC "d_safebcpy='undef'"
$ WC "d_safemcpy='define'"
$ WC "d_sanemcmp='define'"
$ WC "d_sbrkproto='define'"
+$ WC "d_scalbn='undef'"
$ WC "d_scalbnl='undef'"
$ WC "d_sched_yield='" + d_sched_yield + "'"
$ WC "d_scm_rights='undef'"
$ WC "d_tcsetpgrp='undef'"
$ WC "d_telldir='define'"
$ WC "d_telldirproto='define'"
+$ WC "d_tgamma='" + d_tgamma + "'"
$ WC "d_time='define'"
$ WC "d_timegm='undef'"
$ WC "d_times='define'"
$ WC "d_tm_tm_zone='undef'"
$ ENDIF
$ WC "d_truncate='" + d_truncate + "'"
+$ WC "d_trunc='" + d_trunc + "'"
$ WC "d_truncl='" + d_truncl + "'"
$ WC "d_tzname='" + d_tzname + "'"
$ WC "d_u32align='define'"
$ WC "dlext='" + dlext + "'"
$ WC "dlobj='" + dlobj + "'"
$ WC "dlsrc='dl_vms.xs'"
+$ WC "doublekind='3'"
$ WC "doublesize='" + doublesize + "'"
$ WC "drand01='" + drand01 + "'"
$ WC "dtrace='" + "'"
$ WC "d_getservent_r='undef'"
$ WC "d_getspnam_r='undef'"
$ WC "d_gmtime_r='undef'" ! leave undef'd; we use my_gmtime
+$ WC "d_lgamma_r='undef'"
$ WC "d_localtime_r='undef'" ! leave undef'd; we use my_localtime
$ WC "d_localtime_r_needs_tzset='undef'"
$ WC "d_random_r='undef'"
use strict;
use warnings;
package CPAN::Meta::Requirements;
-our $VERSION = '2.128'; # VERSION
# ABSTRACT: a set of version requirements for a CPAN dist
+our $VERSION = '2.130';
+
#pod =head1 SYNOPSIS
#pod
#pod use CPAN::Meta::Requirements;
#pod
#pod =for :list
#pod * C<bad_version_hook> -- if provided, when a version cannot be parsed into
-#pod a version object, this code reference will be called with the invalid version
-#pod string as an argument. It must return a valid version object.
+#pod a version object, this code reference will be called with the invalid
+#pod version string as first argument, and the module name as second
+#pod argument. It must return a valid version object.
#pod
#pod All other keys are ignored.
#pod
}
sub _version_object {
- my ($self, $version) = @_;
+ my ($self, $module, $version) = @_;
my $vobj;
if ( my $err = $@ ) {
my $hook = $self->{bad_version_hook};
- $vobj = eval { $hook->($version) }
+ $vobj = eval { $hook->($version, $module) }
if ref $hook eq 'CODE';
unless (Scalar::Util::blessed($vobj) && $vobj->isa("version")) {
$err =~ s{ at .* line \d+.*$}{};
my $code = sub {
my ($self, $name, $version) = @_;
- $version = $self->_version_object( $version );
+ $version = $self->_version_object( $name, $version );
$self->__modify_entry_for($name, $method, $version);
sub accepts_module {
my ($self, $module, $version) = @_;
- $version = $self->_version_object( $version );
+ $version = $self->_version_object( $module, $version );
return 1 unless my $range = $self->__entry_for($module);
return $range->_accepts($version);
#pod =method add_string_requirement
#pod
#pod $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
+#pod $req->add_string_requirement('Library::Foo' => v1.208);
#pod
#pod This method parses the passed in string and adds the appropriate requirement
-#pod for the given module. It understands version ranges as described in the
-#pod L<CPAN::Meta::Spec/Version Ranges>. For example:
+#pod for the given module. A version can be a Perl "v-string". It understands
+#pod version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
+#pod example:
#pod
#pod =over 4
#pod
sub add_string_requirement {
my ($self, $module, $req) = @_;
- Carp::confess("No requirement string provided for $module")
- unless defined $req && length $req;
+ unless ( defined $req && length $req ) {
+ $req = 0;
+ $self->_blank_carp($module);
+ }
+
+ my $magic = _find_magic_vstring( $req );
+ if (length $magic) {
+ $self->add_minimum($module => $magic);
+ return;
+ }
my @parts = split qr{\s*,\s*}, $req;
-
for my $part (@parts) {
my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};
#pod =method from_string_hash
#pod
#pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
+#pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
#pod
-#pod This is an alternate constructor for a CPAN::Meta::Requirements object. It takes
-#pod a hash of module names and version requirement strings and returns a new
-#pod CPAN::Meta::Requirements object.
+#pod This is an alternate constructor for a CPAN::Meta::Requirements
+#pod object. It takes a hash of module names and version requirement
+#pod strings and returns a new CPAN::Meta::Requirements object. As with
+#pod add_string_requirement, a version can be a Perl "v-string". Optionally,
+#pod you can supply a hash-reference of options, exactly as with the L</new>
+#pod method.
#pod
#pod =cut
+sub _blank_carp {
+ my ($self, $module) = @_;
+ Carp::carp("Undefined requirement for $module treated as '0'");
+}
+
sub from_string_hash {
- my ($class, $hash) = @_;
+ my ($class, $hash, $options) = @_;
- my $self = $class->new;
+ my $self = $class->new($options);
for my $module (keys %$hash) {
my $req = $hash->{$module};
unless ( defined $req && length $req ) {
$req = 0;
- Carp::carp("Undefined requirement for $module treated as '0'");
+ $class->_blank_carp($module);
}
$self->add_string_requirement($module, $req);
}
=head1 VERSION
-version 2.128
+version 2.130
=head1 SYNOPSIS
=item *
-C<bad_version_hook> -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as an argument. It must return a valid version object.
+C<bad_version_hook> -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as first argument, and the module name as second argument. It must return a valid version object.
=back
=head2 add_string_requirement
$req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
+ $req->add_string_requirement('Library::Foo' => v1.208);
This method parses the passed in string and adds the appropriate requirement
-for the given module. It understands version ranges as described in the
-L<CPAN::Meta::Spec/Version Ranges>. For example:
+for the given module. A version can be a Perl "v-string". It understands
+version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
+example:
=over 4
=head2 from_string_hash
my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
+ my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
-This is an alternate constructor for a CPAN::Meta::Requirements object. It takes
-a hash of module names and version requirement strings and returns a new
-CPAN::Meta::Requirements object.
+This is an alternate constructor for a CPAN::Meta::Requirements
+object. It takes a hash of module names and version requirement
+strings and returns a new CPAN::Meta::Requirements object. As with
+add_string_requirement, a version can be a Perl "v-string". Optionally,
+you can supply a hash-reference of options, exactly as with the L</new>
+method.
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 CONTRIBUTORS
-=for stopwords Karen Etheridge robario
+=for stopwords Ed J Karen Etheridge robario
=over 4
=item *
+Ed J <mohawk2@users.noreply.github.com>
+
+=item *
+
Karen Etheridge <ether@cpan.org>
=item *
use Test::More 0.88;
+my %DATA = (
+ 'Foo::Bar' => [ 10, 10 ],
+ 'Foo::Baz' => [ 'invalid_version', 42 ],
+);
+my %input = map { ($_ => $DATA{$_}->[0]) } keys %DATA;
+my %expected = map { ($_ => $DATA{$_}->[1]) } keys %DATA;
+
sub dies_ok (&@) {
my ($code, $qr, $comment) = @_;
}
}
-sub _fixit { return version->new(42) }
+my $hook_text;
+sub _fixit { my ($v, $m) = @_; $hook_text = $m; return version->new(42) }
{
my $req = CPAN::Meta::Requirements->new( {bad_version_hook => \&_fixit} );
- $req->add_minimum('Foo::Bar' => 10);
- $req->add_minimum('Foo::Baz' => 'invalid_version');
+ my ($k, $v);
+ $req->add_minimum($k => $v) while ($k, $v) = each %input;
+ is $hook_text, 'Foo::Baz', 'hook stored module name';
is_deeply(
$req->as_string_hash,
- {
- 'Foo::Bar' => 10,
- 'Foo::Baz' => 42,
- },
+ \%expected,
"hook fixes invalid version",
);
}
}
{
+ my $undef_hash = { Undef => undef };
+ my $z_hash = { ZeroLength => '' };
+
+ my $warning;
+ local $SIG{__WARN__} = sub { $warning = join("\n",@_) };
+
+ my $req = CPAN::Meta::Requirements->from_string_hash($undef_hash);
+ like ($warning, qr/Undefined requirement.*treated as '0'/, "undef requirement warns");
+ $req->add_string_requirement(%$z_hash);
+ like ($warning, qr/Undefined requirement.*treated as '0'/, "'' requirement warns");
+
+ is_deeply(
+ $req->as_string_hash,
+ { map { ($_ => 0) } keys(%$undef_hash), keys(%$z_hash) },
+ "undef/'' requirements treated as '0'",
+ );
+}
+
+{
my $string_hash = {
Left => 10,
- Shared => undef,
+ Shared => v50.44.60,
Right => 18,
};
my $req = CPAN::Meta::Requirements->from_string_hash($string_hash);
- is(
- $req->as_string_hash->{Shared}, 0,
- "undef requirement treated as '0'",
+ ok(
+ $req->accepts_module(Shared => 'v50.44.60'),
+ "vstring treated as if string",
);
+}
- like ($warning, qr/Undefined requirement.*treated as '0'/, "undef requirement warns");
+{
+ my $req = CPAN::Meta::Requirements->from_string_hash(
+ { Bad => 'invalid', },
+ { bad_version_hook => sub { version->new(42) } },
+ );
+
+ ok(
+ $req->accepts_module(Bad => 42),
+ "options work 2nd arg to f_s_h",
+ );
}
done_testing;
use warnings;
package CPAN::Meta;
# VERSION
-$CPAN::Meta::VERSION = '2.142690';
+$CPAN::Meta::VERSION = '2.143240';
#pod =head1 SYNOPSIS
#pod
#pod use v5.10;
#pod
#pod This method returns true if the given file should be indexed. It decides this
#pod by checking the C<file> and C<directory> keys in the C<no_index> property of
-#pod the distmeta structure.
+#pod the distmeta structure. Note that neither the version format nor
+#pod C<release_status> are considered.
#pod
#pod C<$filename> should be given in unix format.
#pod
#pod
#pod This method returns true if the given package should be indexed. It decides
#pod this by checking the C<package> and C<namespace> keys in the C<no_index>
-#pod property of the distmeta structure.
+#pod property of the distmeta structure. Note that neither the version format nor
+#pod C<release_status> are considered.
#pod
#pod =cut
=head1 VERSION
-version 2.142690
+version 2.143240
=head1 SYNOPSIS
This method returns true if the given file should be indexed. It decides this
by checking the C<file> and C<directory> keys in the C<no_index> property of
-the distmeta structure.
+the distmeta structure. Note that neither the version format nor
+C<release_status> are considered.
C<$filename> should be given in unix format.
This method returns true if the given package should be indexed. It decides
this by checking the C<package> and C<namespace> keys in the C<no_index>
-property of the distmeta structure.
+property of the distmeta structure. Note that neither the version format nor
+C<release_status> are considered.
=head2 features
use warnings;
package CPAN::Meta::Converter;
# VERSION
-$CPAN::Meta::Converter::VERSION = '2.142690';
+$CPAN::Meta::Converter::VERSION = '2.143240';
#pod =head1 SYNOPSIS
#pod
#pod my $struct = decode_json_file('META.json');
=head1 VERSION
-version 2.142690
+version 2.143240
=head1 SYNOPSIS
use warnings;
package CPAN::Meta::Feature;
# VERSION
-$CPAN::Meta::Feature::VERSION = '2.142690';
+$CPAN::Meta::Feature::VERSION = '2.143240';
use CPAN::Meta::Prereqs;
#pod =head1 DESCRIPTION
=head1 VERSION
-version 2.142690
+version 2.143240
=head1 DESCRIPTION
use warnings;
package CPAN::Meta::History;
# VERSION
-$CPAN::Meta::History::VERSION = '2.142690';
+$CPAN::Meta::History::VERSION = '2.143240';
1;
# ABSTRACT: history of CPAN Meta Spec changes
=head1 VERSION
-version 2.142690
+version 2.143240
=head1 DESCRIPTION
package CPAN::Meta::Merge;
# VERSION
-$CPAN::Meta::Merge::VERSION = '2.142690';
+$CPAN::Meta::Merge::VERSION = '2.143240';
use Carp qw/croak/;
use Scalar::Util qw/blessed/;
use CPAN::Meta::Converter;
sub _identical {
my ($left, $right, $path) = @_;
- croak "Can't merge attribute " . join '.', @{$path} unless $left eq $right;
+ croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right unless $left eq $right;
return $left;
}
croak sprintf "Can't merge '%s'", join '.', @{$path};
}
+sub _optional_features {
+ my ($left, $right, $path) = @_;
+
+ for my $key (keys %{$right}) {
+ if (not exists $left->{$key}) {
+ $left->{$key} = $right->{$key};
+ }
+ else {
+ for my $subkey (keys %{ $right->{$key} }) {
+ next if $subkey eq 'prereqs';
+ if (not exists $left->{$key}{$subkey}) {
+ $left->{$key}{$subkey} = $right->{$key}{$subkey};
+ }
+ else {
+ Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values"
+ if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} };
+ }
+ }
+
+ require CPAN::Meta::Prereqs;
+ $left->{$key}{prereqs} =
+ CPAN::Meta::Prereqs->new($left->{$key}{prereqs})
+ ->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))
+ ->as_string_hash;
+ }
+ }
+ return $left;
+}
+
+
my %default = (
abstract => \&_identical,
author => \&_set_addition,
description => \&_identical,
keywords => \&_set_addition,
no_index => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ },
- optional_features => \&_uniq_map,
+ optional_features => \&_optional_features,
prereqs => sub {
require CPAN::Meta::Prereqs;
my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1];
my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]);
$ret{$key} = sub {
my ($left, $right, $path) = @_;
- return _merge($left, $right, $mapping, [ @{$path}, $key ]);
+ return _merge($left, $right, $mapping, [ @{$path} ]);
};
}
elsif ($coderef_for{$value}) {
=head1 VERSION
-version 2.142690
+version 2.143240
=head1 SYNOPSIS
use warnings;
package CPAN::Meta::Prereqs;
# VERSION
-$CPAN::Meta::Prereqs::VERSION = '2.142690';
+$CPAN::Meta::Prereqs::VERSION = '2.143240';
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
=head1 VERSION
-version 2.142690
+version 2.143240
=head1 DESCRIPTION
use warnings;
package CPAN::Meta::Spec;
# VERSION
-$CPAN::Meta::Spec::VERSION = '2.142690';
+$CPAN::Meta::Spec::VERSION = '2.143240';
1;
# ABSTRACT: specification for CPAN distribution metadata
=head1 VERSION
-version 2.142690
+version 2.143240
=head1 SYNOPSIS
use warnings;
package CPAN::Meta::Validator;
# VERSION
-$CPAN::Meta::Validator::VERSION = '2.142690';
+$CPAN::Meta::Validator::VERSION = '2.143240';
#pod =head1 SYNOPSIS
#pod
#pod my $struct = decode_json_file('META.json');
=head1 VERSION
-version 2.142690
+version 2.143240
=head1 SYNOPSIS
is_deeply($merger->merge(\%base, { abstract => 'This is a test' }), \%base, 'Can merge in identical abstract');
my $failure = eval { $merger->merge(\%base, { abstract => 'And now for something else' }) };
is($failure, undef, 'Trying to merge different author gives an exception');
-like $@, qr/^Can't merge attribute abstract /, 'Exception looks right';
+like $@, qr/^Can't merge attribute abstract/, 'Exception looks right';
my $failure2 = eval { $merger->merge(\%base, { provides => { Baz => { file => 'Baz.pm' } } }) };
is($failure2, undef, 'Trying to merge different author gives an exception');
--- /dev/null
+use strict;
+use warnings;
+# vim: set ts=4 sw=4 noet nolist :
+
+use Test::More;
+use CPAN::Meta;
+use CPAN::Meta::Merge;
+
+my %base = (
+ abstract => 'This is a test',
+ author => ['A.U. Thor'],
+ generated_by => 'Myself',
+ license => [ 'perl_5' ],
+ resources => {
+ license => [ 'http://dev.perl.org/licenses/' ],
+ },
+ prereqs => {
+ runtime => {
+ requires => {
+ Foo => '0',
+ },
+ },
+ },
+ dynamic_config => 0,
+ provides => {
+ Baz => {
+ file => 'lib/Baz.pm',
+ },
+ },
+ 'meta-spec' => {
+ url => "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ version => 2,
+ },
+);
+
+my $fragment1 = {
+ 'optional_features' => {
+ 'FeatureName' => {
+ 'description' => 'desc',
+ 'x_default' => 1,
+ 'prereqs' => { 'runtime' => { 'requires' => { 'A' => '0' } } }
+ }
+ }
+};
+my $fragment2 = {
+ 'optional_features' => {
+ 'FeatureName' => {
+ 'description' => 'desc',
+ 'prereqs' => { 'test' => { 'requires' => { 'B' => '0' } } }
+ }
+ }
+};
+
+my $merger = CPAN::Meta::Merge->new(default_version => "2");
+my $meta1 = $merger->merge(\%base, $fragment1);
+
+is_deeply(
+ $meta1,
+ {
+ %base,
+ %$fragment1,
+ },
+ 'merged first optional_feature fragment into base',
+);
+
+my $meta2 = $merger->merge($meta1, $fragment2);
+
+is_deeply(
+ $meta2,
+ {
+ %base,
+ 'optional_features' => {
+ 'FeatureName' => {
+ 'description' => 'desc',
+ 'x_default' => 1,
+ 'prereqs' => {
+ 'runtime' => { 'requires' => { 'A' => '0' } },
+ 'test' => { 'requires' => { 'B' => '0' } },
+ }
+ }
+ }
+ },
+ 'merged second optional_feature fragment into the first',
+);
+
+my $fragment3 = {
+ 'optional_features' => {
+ 'FeatureName' => {
+ 'description' => 'other desc',
+ 'prereqs' => { 'test' => { 'requires' => { 'B' => '0' } } }
+ }
+ }
+};
+
+my $result = eval { $merger->merge($meta1, $fragment3) };
+is($result, undef, 'Trying to merge optional_features with same feature name and different descriptions gives an exception');
+like $@, qr/^Cannot merge two optional_features named 'FeatureName' with different 'description' values/, 'Exception looks right';
+
+my $fragment4 = {
+ 'optional_features' => {
+ 'FeatureName' => {
+ 'description' => 'desc',
+ 'x_default' => 0,
+ 'prereqs' => { 'test' => { 'requires' => { 'B' => '0' } } }
+ }
+ }
+};
+
+$result = eval { $merger->merge($meta1, $fragment4) };
+is($result, undef, 'Trying to merge optional_features with same feature name and differences in other keys gives an exception');
+like $@, qr/^Cannot merge two optional_features named 'FeatureName' with different 'x_default' values/, 'Exception looks right';
+
+my $fragment5 = {
+ 'optional_features' => {
+ 'Another FeatureName' => {
+ 'description' => 'desc',
+ 'prereqs' => { 'test' => { 'requires' => { 'B' => '0' } } }
+ }
+ }
+};
+
+my $meta5 = $merger->merge($meta1, $fragment5);
+is_deeply(
+ $meta5,
+ {
+ %base,
+ 'optional_features' => {
+ 'FeatureName' => {
+ 'description' => 'desc',
+ 'x_default' => 1,
+ 'prereqs' => { 'runtime' => { 'requires' => { 'A' => '0' } } },
+ },
+ 'Another FeatureName' => {
+ 'description' => 'desc',
+ 'prereqs' => { 'test' => { 'requires' => { 'B' => '0' } } },
+ }
+ }
+ },
+ 'can merge optional_features with different names without collisions',
+);
+
+done_testing;
+++ /dev/null
-use strict;
-use warnings;
-use Test::More 0.88;
-
-sub dies_ok (&@) {
- my ($code, $qr, $comment) = @_;
-
- my $lived = eval { $code->(); 1 };
-
- if ($lived) {
- fail("$comment: did not die");
- } else {
- like($@, $qr, $comment);
- }
-}
-
-use CPAN::Meta::Requirements;
-
-my $req = CPAN::Meta::Requirements->new;
-
-# Test ==
-$req->add_string_requirement('Foo::Bar', '== 1.3');
-ok($req->accepts_module('Foo::Bar' => '1.3'), 'exact version (==)');
-ok(!$req->accepts_module('Foo::Bar' => '1.2'), 'lower version (==)');
-ok(!$req->accepts_module('Foo::Bar' => '1.4'), 'higher version (==)');
-
-# Test !=
-$req->add_string_requirement('Foo::Baz', '!= 1.3');
-ok(!$req->accepts_module('Foo::Baz' => '1.3'), 'exact version (!=)');
-ok($req->accepts_module('Foo::Baz' => '1.2'), 'lower version (!=)');
-ok($req->accepts_module('Foo::Baz' => '1.4'), 'higher version (!=)');
-
-# Test >=
-$req->add_string_requirement('Foo::Gorch', '>= 1.3');
-ok($req->accepts_module('Foo::Gorch' => '1.3'), 'exact version (>=)');
-ok(!$req->accepts_module('Foo::Gorch' => '1.2'), 'lower version (>=)');
-ok($req->accepts_module('Foo::Gorch' => '1.4'), 'higher version (>=)');
-
-# Test <=
-$req->add_string_requirement('Foo::Graz', '<= 1.3');
-ok($req->accepts_module('Foo::Graz' => '1.3'), 'exact version (<=)');
-ok($req->accepts_module('Foo::Graz' => '1.2'), 'lower version (<=)');
-ok(!$req->accepts_module('Foo::Graz' => '1.4'), 'higher version (<=)');
-
-# Test ""
-$req->add_string_requirement('Foo::Blurb', '>= 1.3');
-ok($req->accepts_module('Foo::Blurb' => '1.3'), 'exact version (>=)');
-ok(!$req->accepts_module('Foo::Blurb' => '1.2'), 'lower version (>=)');
-ok($req->accepts_module('Foo::Blurb' => '1.4'), 'higher version (>=)');
-
-# Test multiple requirements
-$req->add_string_requirement('A::Tribe::Called', '>= 1.3, <= 2.0, != 1.6');
-ok($req->accepts_module('A::Tribe::Called' => '1.5'), 'middle version (>=, <=, !)');
-ok(!$req->accepts_module('A::Tribe::Called' => '1.2'), 'lower version (>=, <=, !)');
-ok(!$req->accepts_module('A::Tribe::Called' => '2.1'), 'higher version (>=, <=, !)');
-ok(!$req->accepts_module('A::Tribe::Called' => '1.6'), 'excluded version (>=, <=, !)');
-
-# Test fatal errors
-dies_ok { $req->add_string_requirement('Foo::Bar', undef) }
- qr/No requirement string provided/,
- "die without a requirement string";
-
-done_testing;
push(@extra, OPTIMIZE => '-O1 -fomit-frame-pointer');
}
-push(@extra, CCFLAGS => '-W -Wall ' . $Config{ccflags}) if $opt_w;
+my $fussy = '-Wall -Wextra -Wconversion -Wcast-align -Wpointer-arith ';
+push(@extra, CCFLAGS => $fussy . $Config{ccflags}) if $opt_w;
my %attr = (
'NAME' => 'Digest::SHA',
CODE:
if ((state = getSHA(self)) == NULL)
XSRETURN_UNDEF;
- RETVAL = ix ? state->alg : state->digestlen << 3;
+ RETVAL = ix ? state->alg : (int) (state->digestlen << 3);
OUTPUT:
RETVAL
ptr = w32mem(ptr, state->lenhl);
ptr = w32mem(ptr, state->lenlh);
ptr = w32mem(ptr, state->lenll);
- RETVAL = newSVpv((char *) buf, ptr - buf);
+ RETVAL = newSVpv((char *) buf, (STRLEN) (ptr - buf));
OUTPUT:
RETVAL
if ((state = getSHA(self)) == NULL)
XSRETURN_UNDEF;
data = (UCHR *) SvPV(packed_state, len);
- if (len != (state->alg <= SHA256 ? 116 : 212))
+ if (len != (state->alg <= SHA256 ? 116U : 212U))
XSRETURN_UNDEF;
data = statecpy(state, data);
Copy(data, state->block, state->blocksize >> 3, UCHR);
if (!f || (state = getSHA(self)) == NULL)
XSRETURN_UNDEF;
while ((n = PerlIO_read(f, in, sizeof(in))) > 0)
- shawrite(in, n << 3, state);
+ shawrite(in, (ULNG) n << 3, state);
XSRETURN(1);
void
SV * self
PerlIO * f
PREINIT:
- char c;
+ UCHR c;
int n;
int cr = 0;
UCHR *src, *dst;
}
}
}
- shawrite(in, (dst - in) << 3, state);
+ shawrite(in, (ULNG) (dst - in) << 3, state);
}
if (cr) {
in[0] = '\012';
use Fcntl;
use integer;
-$VERSION = '5.92';
+$VERSION = '5.93';
require Exporter;
require DynaLoader;
The author is particularly grateful to
Gisle Aas
+ H. Merijn Brand
Sean Burke
Chris Carey
Alexandr Ciornii
Jeffrey Friedl
Robert Gilmour
Brian Gladman
+ Jarkko Hietaniemi
Adam Kennedy
Mark Lawrence
Andy Lester
##
## Copyright (C) 2003-2014 Mark Shelor, All Rights Reserved
##
- ## Version: 5.92
- ## Sun Jun 1 00:15:44 MST 2014
+ ## Version: 5.93
+ ## Sun Oct 26 06:00:48 MST 2014
## shasum SYNOPSIS adapted from GNU Coreutils sha1sum. Add
## "-a" option for algorithm selection,
END_OF_POD
-my $VERSION = "5.92";
+my $VERSION = "5.93";
sub usage {
my($err, $msg) = @_;
*
* Copyright (C) 2003-2014 Mark Shelor, All Rights Reserved
*
- * Version: 5.92
- * Sun Jun 1 00:15:44 MST 2014
+ * Version: 5.93
+ * Sun Oct 26 06:00:48 MST 2014
*
*/
C32(0x90befffa), C32(0xa4506ceb), C32(0xbef9a3f7), C32(0xc67178f2)
};
-static W32 H01[5] = /* SHA-1 initial hash value */
+static W32 H01[8] = /* SHA-1 initial hash value */
{
- C32(0x67452301), C32(0xefcdab89), C32(0x98badcfe),
- C32(0x10325476), C32(0xc3d2e1f0)
+ C32(0x67452301), C32(0xefcdab89), C32(0x98badcfe), C32(0x10325476),
+ C32(0xc3d2e1f0), C32(0x00000000), C32(0x00000000), C32(0x00000000)
};
static W32 H0224[8] = /* SHA-224 initial hash value */
W32 a, b, c, d, e;
W32 W[16];
W32 *wp = W;
- W32 *H = (W32 *) s->H;
+ W32 *H = s->H32;
SHA32_SCHED(W, block);
W32 W[16];
W32 *kp = K256;
W32 *wp = W;
- W32 *H = (W32 *) s->H;
+ W32 *H = s->H32;
SHA32_SCHED(W, block);
#include "sha64bit.c"
-#define SETBIT(s, pos) s[(pos) >> 3] |= (0x01 << (7 - (pos) % 8))
-#define CLRBIT(s, pos) s[(pos) >> 3] &= ~(0x01 << (7 - (pos) % 8))
+#define SETBIT(s, pos) s[(pos) >> 3] |= (UCHR) (0x01 << (7 - (pos) % 8))
+#define CLRBIT(s, pos) s[(pos) >> 3] &= (UCHR) ~(0x01 << (7 - (pos) % 8))
#define NBYTES(nbits) (((nbits) + 7) >> 3)
#define HEXLEN(nbytes) ((nbytes) << 1)
#define B64LEN(nbytes) (((nbytes) % 3 == 0) ? ((nbytes) / 3) * 4 \
{
int i;
UCHR *d = s->digest;
- W32 *p32 = (W32 *) s->H;
- W64 *p64 = (W64 *) s->H;
+ W32 *p32 = s->H32;
+ W64 *p64 = s->H64;
if (s->alg <= SHA256)
for (i = 0; i < 8; i++, d += 4)
static UCHR *statecpy(SHA *s, UCHR *buf)
{
int i;
- W32 *p32 = (W32 *) s->H;
- W64 *p64 = (W64 *) s->H;
+ W32 *p32 = s->H32;
+ W64 *p64 = s->H64;
if (s->alg <= SHA256)
for (i = 0; i < 8; i++, buf += 4)
do { \
Zero(s, 1, SHA); \
s->alg = algo; s->sha = sha ## transform; \
- Copy(H0 ## algo, s->H, sizeof(H0 ## algo), char); \
+ if (s->alg <= SHA256) \
+ Copy(H0 ## algo, s->H32, 8, SHA32); \
+ else \
+ Copy(H0 ## algo, s->H64, 8, SHA64); \
s->blocksize = SHA ## algo ## _BLOCK_BITS; \
s->digestlen = SHA ## algo ## _DIGEST_BITS >> 3; \
} while (0)
ULNG savecnt = bitcnt;
gap = 8 - s->blockcnt % 8;
- s->block[s->blockcnt>>3] &= ~0 << gap;
- s->block[s->blockcnt>>3] |= *bitstr >> (8 - gap);
+ s->block[s->blockcnt>>3] &= (UCHR) (~0 << gap);
+ s->block[s->blockcnt>>3] |= (UCHR) (*bitstr >> (8 - gap));
s->blockcnt += bitcnt < gap ? bitcnt : gap;
if (bitcnt < gap)
return(savecnt);
return(savecnt);
while (nbytes > bufsize) {
for (i = 0; i < bufsize; i++)
- buf[i] = bitstr[i] << gap | bitstr[i+1] >> (8-gap);
+ buf[i] = (UCHR) (bitstr[i] << gap) |
+ (UCHR) (bitstr[i+1] >> (8-gap));
nbits = bitcnt < bufbits ? bitcnt : bufbits;
shabytes(buf, nbits, s);
bitcnt -= nbits, bitstr += bufsize, nbytes -= bufsize;
}
for (i = 0; i < nbytes - 1; i++)
- buf[i] = bitstr[i] << gap | bitstr[i+1] >> (8-gap);
- buf[nbytes-1] = bitstr[nbytes-1] << gap;
+ buf[i] = (UCHR) (bitstr[i] << gap) |
+ (UCHR) (bitstr[i+1] >> (8-gap));
+ buf[nbytes-1] = (UCHR) (bitstr[nbytes-1] << gap);
shabytes(buf, bitcnt, s);
return(savecnt);
}
/* shahex: returns pointer to current digest (hexadecimal) */
static char *shahex(SHA *s)
{
- int i;
+ UINT i;
char *h;
UCHR *d;
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
/* encbase64: encodes input (0 to 3 bytes) into Base 64 */
-static void encbase64(UCHR *in, int n, char *out)
+static void encbase64(UCHR *in, UINT n, char *out)
{
UCHR byte[3] = {0, 0, 0};
/* shabase64: returns pointer to current digest (Base 64) */
static char *shabase64(SHA *s)
{
- int n;
+ UINT n;
UCHR *q;
char out[5];
*
* Copyright (C) 2003-2014 Mark Shelor, All Rights Reserved
*
- * Version: 5.92
- * Sun Jun 1 00:15:44 MST 2014
+ * Version: 5.93
+ * Sun Oct 26 06:00:48 MST 2014
*
*/
#define SHA_MAX_HEX_LEN (SHA_MAX_DIGEST_BITS / 4)
#define SHA_MAX_BASE64_LEN (1 + (SHA_MAX_DIGEST_BITS / 6))
-#if defined(SHA64)
- #define SHA_H_SIZE sizeof(SHA64) * 8
-#else
- #define SHA_H_SIZE sizeof(SHA32) * 8
+#if !defined(SHA64)
+ #define SHA64 SHA32
#endif
typedef struct SHA {
int alg;
void (*sha)(struct SHA *, unsigned char *);
- unsigned char H[SHA_H_SIZE];
+ SHA32 H32[8];
+ SHA64 H64[8];
unsigned char block[SHA_MAX_BLOCK_BITS/8];
unsigned int blockcnt;
unsigned int blocksize;
SHA32 lenhh, lenhl, lenlh, lenll;
unsigned char digest[SHA_MAX_DIGEST_BITS/8];
- int digestlen;
+ unsigned int digestlen;
char hex[SHA_MAX_HEX_LEN+1];
char base64[SHA_MAX_BASE64_LEN+1];
} SHA;
typedef struct {
SHA isha;
SHA osha;
- int digestlen;
+ unsigned int digestlen;
unsigned char key[SHA_MAX_BLOCK_BITS/8];
} HMAC;
*
* Copyright (C) 2003-2014 Mark Shelor, All Rights Reserved
*
- * Version: 5.92
- * Sun Jun 1 00:15:44 MST 2014
+ * Version: 5.93
+ * Sun Oct 26 06:00:48 MST 2014
*
*/
{
W64 a, b, c, d, e, f, g, h, T1, T2;
W64 W[80];
- W64 *H = (W64 *) s->H;
+ W64 *H = s->H64;
int t;
SHA64_SCHED(W, block);
*
* Copyright (C) 2003-2014 Mark Shelor, All Rights Reserved
*
- * Version: 5.92
- * Sun Jun 1 00:15:44 MST 2014
+ * Version: 5.93
+ * Sun Oct 26 06:00:48 MST 2014
*
* The following macros supply placeholder values that enable the
* sha.c module to successfully compile when 64-bit integer types
*/
#define sha_384_512 0
-#define W64 unsigned long
+#define W64 SHA32
#define sha512 NULL
#define H0384 H01
#define H0512 H01
print $fh "MacOS\r" . "MSDOS\r\n" . "UNIX\n" . "Quirky\r\r\n";
$fh->close;
-print "not " unless $sha->new(1)->addfile($tempfile, "U")->hexdigest eq
- "f4c6855783c737c7e224873c90e80a9df5c2bc97"; # per Python 3
-print "ok ", $testnum++, "\n";
+my $d = $sha->new(1)->addfile($tempfile, "U")->hexdigest;
+if ($d eq "f4c6855783c737c7e224873c90e80a9df5c2bc97") {
+ print "ok ", $testnum++, "\n";
+}
+elsif ($d eq "42335d4a517a5e31399e948e9d842bafd9194d8f") {
+ print "ok ", $testnum++, " # skip: flaky -T\n";
+}
+else {
+ print "not ok ", $testnum++, "\n";
+}
# test addfile BITS mode
$self->{'clean'}{'FILES'} .= join(' ',@files);
open(XS,">$name.xs") || die "Cannot open $name.xs:$!";
print XS <<'END';
+#define PERL_NO_GET_CONTEXT
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
$self->{'clean'}{'FILES'} .= join(' ',@files);
open(XS,">$name.xs") || die "Cannot open $name.xs:$!";
print XS <<'END';
+#define PERL_NO_GET_CONTEXT
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
$self->{'clean'}{'FILES'} .= join(' ',@files);
open(XS,">$name.xs") || die "Cannot open $name.xs:$!";
print XS <<'END';
+#define PERL_NO_GET_CONTEXT
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#
-# $Id: Encode.pm,v 2.62 2014/05/31 12:12:39 dankogai Exp dankogai $
+# $Id: Encode.pm,v 2.64 2014/10/29 15:37:54 dankogai Exp dankogai $
#
package Encode;
use strict;
use warnings;
-our $VERSION = sprintf "%d.%02d", q$Revision: 2.62 $ =~ /(\d+)/g;
+our $VERSION = sprintf "%d.%02d", q$Revision: 2.64 $ =~ /(\d+)/g;
use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG};
use XSLoader ();
XSLoader::load( __PACKAGE__, $VERSION );
require Carp;
Carp::croak("Unknown encoding '$name'");
}
- my $octets = $enc->encode( $string, $check );
+ # For Unicode, warnings need to be caught and re-issued at this level
+ # so that callers can disable utf8 warnings lexically.
+ my $octets;
+ if ( ref($enc) eq 'Encode::Unicode' ) {
+ my $warn = '';
+ {
+ local $SIG{__WARN__} = sub { $warn = shift };
+ $octets = $enc->encode( $string, $check );
+ }
+ warnings::warnif('utf8', $warn) if length $warn;
+ }
+ else {
+ $octets = $enc->encode( $string, $check );
+ }
$_[1] = $string if $check and !ref $check and !( $check & LEAVE_SRC() );
return $octets;
}
require Carp;
Carp::croak("Unknown encoding '$name'");
}
- my $string = $enc->decode( $octets, $check );
+ # For Unicode, warnings need to be caught and re-issued at this level
+ # so that callers can disable utf8 warnings lexically.
+ my $string;
+ if ( ref($enc) eq 'Encode::Unicode' ) {
+ my $warn = '';
+ {
+ local $SIG{__WARN__} = sub { $warn = shift };
+ $string = $enc->decode( $octets, $check );
+ }
+ warnings::warnif('utf8', $warn) if length $warn;
+ }
+ else {
+ $string = $enc->decode( $octets, $check );
+ }
$_[1] = $octets if $check and !ref $check and !( $check & LEAVE_SRC() );
return $string;
}
/*
- $Id: Encode.xs,v 2.29 2014/05/31 12:12:39 dankogai Exp dankogai $
+ $Id: Encode.xs,v 2.31 2014/10/29 15:37:54 dankogai Exp dankogai $
*/
#define PERL_NO_GET_CONTEXT
encode_method(). 1 is recommended. 2 restores NI-S original */
#define ENCODE_XS_USEFP 1
-#define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {dTHX; \
- Perl_croak(aTHX_ "panic_unimplemented"); \
+#define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) { \
+ Perl_croak_nocontext("panic_unimplemented"); \
return (y)0; /* fool picky compilers */ \
}
/**/
if (UTF8_IS_START(*s)) {
U8 skip = UTF8SKIP(s);
if ((s + skip) > e) {
- /* Partial character */
- /* XXX could check that rest of bytes are UTF8_IS_CONTINUATION(ch) */
- if (stop_at_partial || (check & ENCODE_STOP_AT_PARTIAL))
+ if (stop_at_partial || (check & ENCODE_STOP_AT_PARTIAL)) {
+ const U8 *p = s + 1;
+ for (; p < e; p++) {
+ if (!UTF8_IS_CONTINUATION(*p))
+ goto malformed_byte;
+ }
break;
+ }
goto malformed_byte;
}
/* require_pv(PERLIO_FILENAME); */
eval_pv("require PerlIO::encoding", 0);
+ SPAGAIN;
if (SvTRUE(get_sv("@", 0))) {
ST(0) = &PL_sv_no;
encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
SV *retval;
eval_pv("require Encode::MIME::Name", 0);
+ SPAGAIN;
if (SvTRUE(get_sv("@", 0))) {
ST(0) = &PL_sv_undef;
$self->{'clean'}{'FILES'} .= join(' ',@files);
open(XS,">$name.xs") || die "Cannot open $name.xs:$!";
print XS <<'END';
+#define PERL_NO_GET_CONTEXT
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
$self->{'clean'}{'FILES'} .= join(' ',@files);
open(XS,">$name.xs") || die "Cannot open $name.xs:$!";
print XS <<'END';
+#define PERL_NO_GET_CONTEXT
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
$self->{'clean'}{'FILES'} .= join(' ',@files);
open(XS,">$name.xs") || die "Cannot open $name.xs:$!";
print XS <<'END';
+#define PERL_NO_GET_CONTEXT
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
$self->{'clean'}{'FILES'} .= join(' ',@files);
open(XS,">$name.xs") || die "Cannot open $name.xs:$!";
print XS <<'END';
+#define PERL_NO_GET_CONTEXT
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
use Getopt::Std;
use Config;
my @orig_ARGV = @ARGV;
-our $VERSION = do { my @r = (q$Revision: 2.13 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+our $VERSION = do { my @r = (q$Revision: 2.14 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
# These may get re-ordered.
# RAW is a do_now as inserted by &enter
if ($cname =~ /(\w+)\.xs$/)
{
+ print C "#define PERL_NO_GET_CONTEXT\n";
print C "#include <EXTERN.h>\n";
print C "#include <perl.h>\n";
print C "#include <XSUB.h>\n";
*/
+#define PERL_NO_GET_CONTEXT
#include <EXTERN.h>
#include <perl.h>
#include "encode.h"
--- /dev/null
+use strict;
+use warnings;
+BEGIN {
+ if ($] < 5.014){
+ print "1..0 # Skip: Perl 5.14.0 or later required\n";
+ exit 0;
+ }
+}
+
+use Encode;
+use Test::More tests => 7;
+
+my $valid = "\x61\x00\x00\x00";
+my $invalid = "\x78\x56\x34\x12";
+
+my @warnings;
+$SIG{__WARN__} = sub {push @warnings, "@_"};
+
+my $enc = find_encoding("UTF32-LE");
+
+{
+ @warnings = ();
+ my $ret = Encode::Unicode::decode( $enc, $valid );
+ is("@warnings", "", "Calling decode in Encode::Unicode on valid string produces no warnings");
+}
+
+{
+ @warnings = ();
+ my $ret = Encode::Unicode::decode( $enc, $invalid );
+ like("@warnings", qr/is not Unicode/, "Calling decode in Encode::Unicode on invalid string warns");
+}
+
+{
+ no warnings 'utf8';
+ @warnings = ();
+ my $ret = Encode::Unicode::decode( $enc, $invalid );
+ is("@warnings", "", "Warning from decode in Encode::Unicode can be silenced via no warnings 'utf8'");
+}
+
+{
+ no warnings;
+ @warnings = ();
+ my $ret = Encode::Unicode::decode( $enc, $invalid );
+ is("@warnings", "", "Warning from decode in Encode::Unicode can be silenced via no warnings");
+}
+
+{
+ @warnings = ();
+ my $ret = Encode::decode( $enc, $invalid );
+ like("@warnings", qr/is not Unicode/, "Calling decode in Encode on invalid string warns");
+}
+
+{
+ no warnings 'utf8';
+ @warnings = ();
+ my $ret = Encode::decode( $enc, $invalid );
+ is("@warnings", "", "Warning from decode in Encode can be silenced via no warnings 'utf8'");
+};
+
+{
+ no warnings;
+ @warnings = ();
+ my $ret = Encode::decode( $enc, $invalid );
+ is("@warnings", "", "Warning from decode in Encode can be silenced via no warnings 'utf8'");
+};
+
our @EXPORT = qw(test_harness pod2man perllocal_install uninstall
warn_if_old_packlist test_s cp_nonempty);
-our $VERSION = '6.98';
+our $VERSION = '7.02';
my $Is_VMS = $^O eq 'VMS';
'section|s=s', 'release|r=s', 'center|c=s',
'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s',
'fixedbolditalic=s', 'official|o', 'quotes|q=s', 'lax|l',
- 'name|n=s', 'perm_rw=i'
+ 'name|n=s', 'perm_rw=i', 'utf8|u'
);
+ delete $options{utf8} unless $Pod::Man::VERSION >= 2.17;
# If there's no files, don't bother going further.
return 0 unless @ARGV;
# This isn't a valid Pod::Man option and is only accepted for backwards
# compatibility.
delete $options{lax};
+ my $count = scalar @ARGV / 2;
+ my $plural = $count == 1 ? 'document' : 'documents';
+ print "Manifying $count pod $plural\n";
do {{ # so 'next' works
my ($pod, $man) = splice(@ARGV, 0, 2);
(mtime($man) > mtime($pod)) &&
(mtime($man) > mtime("Makefile")));
- print "Manifying $man\n";
-
my $parser = Pod::Man->new(%options);
$parser->parse_from_file($pod, $man)
or do { warn("Could not install $man\n"); next };
use strict;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
use File::Spec;
require ExtUtils::Liblist::Kid;
use strict;
use warnings;
-our $VERSION = '6.98_01';
+our $VERSION = '7.02';
use ExtUtils::MakeMaker::Config;
use Cwd 'cwd';
# this is a rewrite of Andy Dougherty's extliblist in perl
my ( @searchpath ); # from "-L/path" entries in $potential_libs
- my ( @libpath ) = split " ", $Config{'libpth'};
+ my ( @libpath ) = split " ", $Config{'libpth'} || '';
my ( @ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen );
my ( @libs, %libs_seen );
my ( $fullname, @fullname );
my ( $found ) = 0;
foreach my $thislib ( split ' ', $potential_libs ) {
+ my ( $custom_name ) = '';
# Handle possible linker path arguments.
if ( $thislib =~ s/^(-[LR]|-Wl,-R|-Wl,-rpath,)// ) { # save path flag type
}
# Handle possible library arguments.
- unless ( $thislib =~ s/^-l// ) {
+ if ( $thislib =~ s/^-l(:)?// ) {
+ # Handle -l:foo.so, which means that the library will
+ # actually be called foo.so, not libfoo.so. This
+ # is used in Android by ExtUtils::Depends to allow one XS
+ # module to link to another.
+ $custom_name = $1 || '';
+ }
+ else {
warn "Unrecognized argument in LIBS ignored: '$thislib'\n";
next;
}
#
# , the compilation tools expand the environment variables.)
}
+ elsif ( $custom_name && -f ( $fullname = "$thispth/$thislib" ) ) {
+ }
else {
warn "$thislib not found in $thispth\n" if $verbose;
next;
# what do we know about this library...
my $is_dyna = ( $fullname !~ /\Q$Config_libext\E\z/ );
- my $in_perl = ( $libs =~ /\B-l\Q${thislib}\E\b/s );
+ my $in_perl = ( $libs =~ /\B-l:?\Q${thislib}\E\b/s );
# include the path to the lib once in the dynamic linker path
# but only if it is a dynamic lib and not in Perl itself
&& ( $thislib eq 'm' || $thislib eq 'ndbm' ) )
)
{
- push( @extralibs, "-l$thislib" );
+ push( @extralibs, "-l$custom_name$thislib" );
}
# We might be able to load this archive file dynamically
# For SunOS4, do not add in this shared library if
# it is already linked in the main perl executable
- push( @ldloadlibs, "-l$thislib" )
+ push( @ldloadlibs, "-l$custom_name$thislib" )
unless ( $in_perl and $^O eq 'sunos' );
}
else {
- push( @ldloadlibs, "-l$thislib" );
+ push( @ldloadlibs, "-l$custom_name$thislib" );
}
}
last; # found one here so don't bother looking further
return ( '', '', '', '', ( $give_libs ? \@libs : () ) ) unless @extralibs;
# make sure paths with spaces are properly quoted
- @extralibs = map { /\s/ ? qq["$_"] : $_ } @extralibs;
- @libs = map { /\s/ ? qq["$_"] : $_ } @libs;
+ @extralibs = map { qq["$_"] } @extralibs;
+ @libs = map { qq["$_"] } @libs;
my $lib = join( ' ', @extralibs );
use strict;
use ExtUtils::MakeMaker::Config;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
require ExtUtils::Liblist;
require ExtUtils::MakeMaker;
package ExtUtils::MM_AIX;
use strict;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
package ExtUtils::MM_Any;
use strict;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
use Carp;
use File::Spec;
}
+=head3 can_run
+
+ use ExtUtils::MM;
+ my $runnable = MM->can_run($Config{make});
+
+If called in a scalar context it will return the full path to the binary
+you asked for if it was found, or C<undef> if it was not.
+
+If called in a list context, it will return a list of the full paths to instances
+of the binary where found in C<PATH>, or an empty list if it was not found.
+
+Copied from L<IPC::Cmd|IPC::Cmd/"$path = can_run( PROGRAM );">, but modified into
+a method (and removed C<$INSTANCES> capability).
+
+=cut
+
+sub can_run {
+ my ($self, $command) = @_;
+
+ # a lot of VMS executables have a symbol defined
+ # check those first
+ if ( $^O eq 'VMS' ) {
+ require VMS::DCLsym;
+ my $syms = VMS::DCLsym->new;
+ return $command if scalar $syms->getsym( uc $command );
+ }
+
+ my @possibles;
+
+ if( File::Spec->file_name_is_absolute($command) ) {
+ return $self->maybe_command($command);
+
+ } else {
+ for my $dir (
+ File::Spec->path,
+ File::Spec->curdir
+ ) {
+ next if ! $dir || ! -d $dir;
+ my $abs = File::Spec->catfile($self->os_flavor_is('Win32') ? Win32::GetShortPathName( $dir ) : $dir, $command);
+ push @possibles, $abs if $abs = $self->maybe_command($abs);
+ }
+ }
+ return @possibles if wantarray;
+ return shift @possibles;
+}
+
+
+=head3 can_redirect_error
+
+ $useredirect = MM->can_redirect_error;
+
+True if on an OS where qx operator (or backticks) can redirect C<STDERR>
+onto C<STDOUT>.
+
+=cut
+
+sub can_redirect_error {
+ my $self = shift;
+ $self->os_flavor_is('Unix')
+ or ($self->os_flavor_is('Win32') and !$self->os_flavor_is('Win9x'))
+ or $self->os_flavor_is('OS/2')
+}
+
+
+=head3 is_make_type
+
+ my $is_dmake = $self->is_make_type('dmake');
+
+Returns true if C<<$self->make>> is the given type; possibilities are:
+
+ gmake GNU make
+ dmake
+ nmake
+ bsdmake BSD pmake-derived
+
+=cut
+
+sub is_make_type {
+ my($self, $type) = @_;
+ (undef, undef, my $make_basename) = $self->splitpath($self->make);
+ return 1 if $make_basename =~ /\b$type\b/; # executable's filename
+ # now have to run with "-v" and guess
+ my $redirect = $self->can_redirect_error ? '2>&1' : '';
+ my $make = $self->make || $self->{MAKE};
+ my $minus_v = `"$make" -v $redirect`;
+ return 1 if $type eq 'gmake' and $minus_v =~ /GNU make/i;
+ return 1 if $type eq 'bsdmake'
+ and $minus_v =~ /^usage: make \[-BeikNnqrstWwX\]/im;
+ 0; # it wasn't whatever you asked
+}
+
+
+=head3 can_dep_space
+
+ my $can_dep_space = $self->can_dep_space;
+
+Returns true if C<make> can handle (probably by quoting)
+dependencies that contain a space. Currently known true for GNU make,
+false for BSD pmake derivative.
+
+=cut
+
+my $cached_dep_space;
+sub can_dep_space {
+ my $self = shift;
+ return $cached_dep_space if defined $cached_dep_space;
+ return $cached_dep_space = 1 if $self->is_make_type('gmake');
+ return $cached_dep_space = 0 if $self->is_make_type('dmake'); # only on W32
+ return $cached_dep_space = 0 if $self->is_make_type('bsdmake');
+ return $cached_dep_space = 0; # assume no
+}
+
+
+=head3 quote_dep
+
+ $text = $mm->quote_dep($text);
+
+Method that protects Makefile single-value constants (mainly filenames),
+so that make will still treat them as single values even if they
+inconveniently have spaces in. If the make program being used cannot
+achieve such protection and the given text would need it, throws an
+exception.
+
+=cut
+
+sub quote_dep {
+ my ($self, $arg) = @_;
+ die <<EOF if $arg =~ / / and not $self->can_dep_space;
+Tried to use make dependency with space for make that can't:
+ '$arg'
+EOF
+ $arg =~ s/( )/\\$1/g; # how GNU make does it
+ return $arg;
+}
+
+
=head3 split_command
my @cmds = $MM->split_command($cmd, @args);
my @man_cmds;
foreach my $section (qw(1 3)) {
my $pods = $self->{"MAN${section}PODS"};
- push @man_cmds, $self->split_command(<<CMD, map {($_,$pods->{$_})} sort keys %$pods);
- \$(NOECHO) \$(POD2MAN) --section=$section --perm_rw=\$(PERM_RW)
+ my $p2m = sprintf <<CMD, $] > 5.008 ? " -u" : "";
+ \$(NOECHO) \$(POD2MAN) --section=$section --perm_rw=\$(PERM_RW)%s
CMD
+ push @man_cmds, $self->split_command($p2m, map {($_,$pods->{$_})} sort keys %$pods);
}
$manify .= "\t\$(NOECHO) \$(NOOP)\n" unless @man_cmds;
# Check the original args so we can tell between the user setting it
# to an empty hash and it just being initialized.
if( $self->{ARGS}{CONFIGURE_REQUIRES} ) {
- $meta{configure_requires}
- = _normalize_prereqs($self->{CONFIGURE_REQUIRES});
+ $meta{configure_requires} = $self->{CONFIGURE_REQUIRES};
} else {
$meta{configure_requires} = {
'ExtUtils::MakeMaker' => 0,
}
if( $self->{ARGS}{BUILD_REQUIRES} ) {
- $meta{build_requires} = _normalize_prereqs($self->{BUILD_REQUIRES});
+ $meta{build_requires} = $self->{BUILD_REQUIRES};
} else {
$meta{build_requires} = {
'ExtUtils::MakeMaker' => 0,
if( $self->{ARGS}{TEST_REQUIRES} ) {
$meta{build_requires} = {
%{ $meta{build_requires} },
- %{ _normalize_prereqs($self->{TEST_REQUIRES}) },
+ %{ $self->{TEST_REQUIRES} },
};
}
- $meta{requires} = _normalize_prereqs($self->{PREREQ_PM})
+ $meta{requires} = $self->{PREREQ_PM}
if defined $self->{PREREQ_PM};
$meta{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION})
if $self->{MIN_PERL_VERSION};
# Check the original args so we can tell between the user setting it
# to an empty hash and it just being initialized.
if( $self->{ARGS}{CONFIGURE_REQUIRES} ) {
- $meta{prereqs}{configure}{requires}
- = _normalize_prereqs($self->{CONFIGURE_REQUIRES});
+ $meta{prereqs}{configure}{requires} = $self->{CONFIGURE_REQUIRES};
} else {
$meta{prereqs}{configure}{requires} = {
'ExtUtils::MakeMaker' => 0,
}
if( $self->{ARGS}{BUILD_REQUIRES} ) {
- $meta{prereqs}{build}{requires} = _normalize_prereqs($self->{BUILD_REQUIRES});
+ $meta{prereqs}{build}{requires} = $self->{BUILD_REQUIRES};
} else {
$meta{prereqs}{build}{requires} = {
'ExtUtils::MakeMaker' => 0,
}
if( $self->{ARGS}{TEST_REQUIRES} ) {
- $meta{prereqs}{test}{requires} = _normalize_prereqs($self->{TEST_REQUIRES});
+ $meta{prereqs}{test}{requires} = $self->{TEST_REQUIRES};
}
- $meta{prereqs}{runtime}{requires} = _normalize_prereqs($self->{PREREQ_PM})
+ $meta{prereqs}{runtime}{requires} = $self->{PREREQ_PM}
if $self->{ARGS}{PREREQ_PM};
$meta{prereqs}{runtime}{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION})
if $self->{MIN_PERL_VERSION};
return %meta;
}
-sub _normalize_prereqs {
- my ($hash) = @_;
- my %prereqs;
- while ( my ($k,$v) = each %$hash ) {
- $prereqs{$k} = _normalize_version($v);
- }
- return \%prereqs;
-}
-
# Adapted from Module::Build::Base
sub _normalize_version {
my ($version) = @_;
if (defined $self->{VERSION}) {
if ( $self->{VERSION} !~ /^\s*v?[\d_\.]+\s*$/ ) {
require version;
- my $normal = eval { version->parse( $self->{VERSION} ) };
+ my $normal = eval { version->new( $self->{VERSION} ) };
$self->{VERSION} = $normal if defined $normal;
}
$self->{VERSION} =~ s/^\s+//;
sub init_tools {
my $self = shift;
- $self->{ECHO} ||= $self->oneliner('print qq{@ARGV}', ['-l']);
+ $self->{ECHO} ||= $self->oneliner('binmode STDOUT, qq{:raw}; print qq{@ARGV}', ['-l']);
$self->{ECHO_N} ||= $self->oneliner('print qq{@ARGV}');
$self->{TOUCH} ||= $self->oneliner('touch', ["-MExtUtils::Command"]);
sub _perl_header_files {
my $self = shift;
- my $header_dir = $self->{PERL_SRC} || $self->catdir($Config{archlibexp}, 'CORE');
+ my $header_dir = $self->{PERL_SRC} || $ENV{PERL_SRC} || $self->catdir($Config{archlibexp}, 'CORE');
opendir my $dh, $header_dir
or die "Failed to opendir '$header_dir' to find header files: $!";
return join("\\\n",
"PERL_HDRS = ",
map {
- sprintf( " \$(PERL_INC)%s%s ", $separator, $_ )
+ sprintf( " \$(PERL_INCDEP)%s%s ", $separator, $_ )
} $self->_perl_header_files()
) . "\n\n"
. "\$(OBJECT) : \$(PERL_HDRS)\n";
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
-our $VERSION = '6.98';
+our $VERSION = '7.02';
=item os_flavor
$self->{PERL_ARCHIVE} ||=
File::Spec->catdir('$(PERL_INC)',$Config{libperl});
+ $self->{PERL_ARCHIVEDEP} ||= '';
$self->{PERL_ARCHIVE_AFTER} ||= '';
$self->{EXPORT_LIST} ||= '';
}
require ExtUtils::MM_Win32;
our @ISA = qw( ExtUtils::MM_Unix );
-our $VERSION = '6.98';
+our $VERSION = '7.02';
=head1 NAME
'$(PERL_INC)' .'/'. ("$Config{libperl}" or "libperl.a");
}
+ $self->{PERL_ARCHIVEDEP} ||= '';
$self->{PERL_ARCHIVE_AFTER} ||= '';
$self->{EXPORT_LIST} ||= '';
}
use strict;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Unix );
}
-our $VERSION = '6.98';
+our $VERSION = '7.02';
=head1 NAME
use strict;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
sub new {
die <<'UNSUPPORTED';
use ExtUtils::MakeMaker::Config;
use File::Basename;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
require ExtUtils::MM_Win32;
our @ISA = qw(ExtUtils::MM_Win32);
use ExtUtils::MakeMaker qw(neatvalue);
use File::Spec;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
$self->{PERL_ARCHIVE} = "\$(PERL_INC)/libperl\$(LIB_EXT)";
+ $self->{PERL_ARCHIVEDEP} ||= '';
$self->{PERL_ARCHIVE_AFTER} = $OS2::is_aout
? ''
: '$(PERL_INC)/libperl_override$(LIB_EXT)';
package ExtUtils::MM_QNX;
use strict;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
package ExtUtils::MM_UWIN;
use strict;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
# If we make $VERSION an our variable parse_version() breaks
use vars qw($VERSION);
-$VERSION = '6.98';
+$VERSION = '7.02';
$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval]
require ExtUtils::MM_Any;
@cflags{qw(cc ccflags optimize shellflags)}
= @Config{qw(cc ccflags optimize shellflags)};
+
+ # Perl 5.21.4 adds the (gcc) warning (-Wall ...) and std (-std=c89)
+ # flags to the %Config, and the modules in the core can be built
+ # with those.
+ my @ccextraflags = qw(ccwarnflags ccstdflags);
+ if ($ENV{PERL_CORE}) {
+ for my $x (@ccextraflags) {
+ if (exists $Config{$x}) {
+ $cflags{$x} = $Config{$x};
+ }
+ }
+ }
+
my($optdebug) = "";
$cflags{shellflags} ||= '';
$self->{CCFLAGS} .= ' -DPERL_POLLUTE ';
}
+ for my $x (@ccextraflags) {
+ next unless exists $cflags{$x};
+ $self->{CCFLAGS} .= $cflags{$x} =~ m!^\s! ? $cflags{$x} : ' ' . $cflags{$x};
+ }
+
my $pollute = '';
if ($Config{usemymalloc} and not $Config{bincompat5005}
and not $Config{ccflags} =~ /-DPERL_POLLUTE_MALLOC\b/
} $self->installvars),
qw(
PERL_LIB
- PERL_ARCHLIB
+ PERL_ARCHLIB PERL_ARCHLIBDEP
LIBPERL_A MYEXTLIB
FIRST_MAKEFILE MAKEFILE_OLD MAKE_APERL_FILE
- PERLMAINCC PERL_SRC PERL_INC
+ PERLMAINCC PERL_SRC PERL_INC PERL_INCDEP
PERL FULLPERL ABSPERL
PERLRUN FULLPERLRUN ABSPERLRUN
PERLRUNINST FULLPERLRUNINST ABSPERLRUNINST
# pathnames can have sharp signs in them; escape them so
# make doesn't think it is a comment-start character.
$self->{$macro} =~ s/#/\\#/g;
+ $self->{$macro} = $self->quote_dep($self->{$macro})
+ if $ExtUtils::MakeMaker::macro_dep{$macro};
push @m, "$macro = $self->{$macro}\n";
}
push @m, q{
# Where is the Config information that we are using/depend on
-CONFIGDEP = $(PERL_ARCHLIB)$(DFSEP)Config.pm $(PERL_INC)$(DFSEP)config.h
+CONFIGDEP = $(PERL_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_INCDEP)$(DFSEP)config.h
} if -e File::Spec->catfile( $self->{PERL_INC}, 'config.h' );
INST_BOOT = $self->{INST_BOOT}
};
-
push @m, qq{
# Extra linker info
EXPORT_LIST = $self->{EXPORT_LIST}
PERL_ARCHIVE = $self->{PERL_ARCHIVE}
+PERL_ARCHIVEDEP = $self->{PERL_ARCHIVEDEP}
PERL_ARCHIVE_AFTER = $self->{PERL_ARCHIVE_AFTER}
};
$(NOECHO) $(PERLRUN) \
"-MExtUtils::Mkbootstrap" \
-e "Mkbootstrap('$(BASEEXT)','$(BSLOADLIBS)');"
- $(NOECHO) $(TOUCH) %s
- $(CHMOD) $(PERM_RW) %s
+ $(NOECHO) $(TOUCH) "%s"
+ $(CHMOD) $(PERM_RW) "%s"
MAKE_FRAG
}
INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
INST_DYNAMIC_FIX = '.$ld_fix.'
-$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP)
+$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP)
');
if ($armaybe ne ':'){
$ldfrom = 'tmp$(LIB_EXT)';
# platforms. We peek at lddlflags to see if we need -Wl,-R
# or -R to add paths to the run-time library search path.
if ($Config{'lddlflags'} =~ /-Wl,-R/) {
- $libs .= ' -L$(PERL_INC) -Wl,-R$(INSTALLARCHLIB)/CORE -Wl,-R$(PERL_ARCHLIB)/CORE -lperl';
+ $libs .= ' "-L$(PERL_INC)" "-Wl,-R$(INSTALLARCHLIB)/CORE" "-Wl,-R$(PERL_ARCHLIB)/CORE" -lperl';
} elsif ($Config{'lddlflags'} =~ /-R/) {
- $libs .= ' -L$(PERL_INC) -R$(INSTALLARCHLIB)/CORE -R$(PERL_ARCHLIB)/CORE -lperl';
+ $libs .= ' "-L$(PERL_INC)" "-R$(INSTALLARCHLIB)/CORE" "-R$(PERL_ARCHLIB)/CORE" -lperl';
} elsif ( $Is{Android} ) {
# The Android linker will not recognize symbols from
# libperl unless the module explicitly depends on it.
- $libs .= ' -L$(PERL_INC) -lperl';
+ $libs .= ' "-L$(PERL_INC)" -lperl';
}
}
next unless $self->maybe_command($abs);
print "Executing $abs\n" if ($trace >= 2);
- my $version_check = qq{$abs -le "require $ver; print qq{VER_OK}"};
+ my $version_check = qq{"$abs" -le "require $ver; print qq{VER_OK}"};
# To avoid using the unportable 2>&1 to suppress STDERR,
# we close it before running the command.
$shb .= ' ' . $arg if defined $arg;
$shb .= "\n";
}
- $shb .= qq{
-eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
- if 0; # not running under some shell
-} unless $Is{Win32}; # this won't work on win32, so don't
}
else {
warn "Can't find $cmd in PATH, $file unchanged"
$self->{PERL_LIB} = File::Spec->rel2abs($self->{PERL_LIB});
$self->{PERL_ARCHLIB} = File::Spec->rel2abs($self->{PERL_ARCHLIB});
}
+ $self->{PERL_INCDEP} = $self->{PERL_INC};
+ $self->{PERL_ARCHLIBDEP} = $self->{PERL_ARCHLIB};
# We get SITELIBEXP and SITEARCHEXP directly via
# Get_from_Config. When we are running standard modules, these
sub init_linker {
my($self) = shift;
$self->{PERL_ARCHIVE} ||= '';
+ $self->{PERL_ARCHIVEDEP} ||= '';
$self->{PERL_ARCHIVE_AFTER} ||= '';
$self->{EXPORT_LIST} ||= '';
}
$self->{PERL} ||=
$self->find_perl(5.0, \@perls, \@defpath, $Verbose );
- # don't check if perl is executable, maybe they have decided to
- # supply switches with perl
+
+ my $perl = $self->{PERL};
+ $perl =~ s/^"//;
+ my $has_mcr = $perl =~ s/^MCR\s*//;
+ my $perlflags = '';
+ my $stripped_perl;
+ while ($perl) {
+ ($stripped_perl = $perl) =~ s/"$//;
+ last if -x $stripped_perl;
+ last unless $perl =~ s/(\s+\S+)$//;
+ $perlflags = $1.$perlflags;
+ }
+ $self->{PERL} = $stripped_perl;
+ $self->{PERL} = 'MCR '.$self->{PERL} if $has_mcr || $Is{VMS};
# When built for debugging, VMS doesn't create perl.exe but ndbgperl.exe.
my $perl_name = 'perl';
# XXX This logic is flawed. If "miniperl" is anywhere in the path
# it will get confused. It should be fixed to work only on the filename.
# Define 'FULLPERL' to be a non-miniperl (used in test: target)
- ($self->{FULLPERL} = $self->{PERL}) =~ s/\Q$miniperl\E$/$perl_name$Config{exe_ext}/i
- unless $self->{FULLPERL};
+ unless ($self->{FULLPERL}) {
+ ($self->{FULLPERL} = $self->{PERL}) =~ s/\Q$miniperl\E$/$perl_name$Config{exe_ext}/i;
+ $self->{FULLPERL} = qq{"$self->{FULLPERL}"}.$perlflags;
+ }
+ # Can't have an image name with quotes, and findperl will have
+ # already escaped spaces.
+ $self->{FULLPERL} =~ tr/"//d if $Is{VMS};
# Little hack to get around VMS's find_perl putting "MCR" in front
# sometimes.
$self->{ABSPERL} = $self->{PERL};
- my $has_mcr = $self->{ABSPERL} =~ s/^MCR\s*//;
+ $has_mcr = $self->{ABSPERL} =~ s/^MCR\s*//;
if( $self->file_name_is_absolute($self->{ABSPERL}) ) {
$self->{ABSPERL} = '$(PERL)';
}
$self->{ABSPERL} = 'MCR '.$self->{ABSPERL} if $has_mcr;
}
+ $self->{PERL} = qq{"$self->{PERL}"}.$perlflags;
+
+ # Can't have an image name with quotes, and findperl will have
+ # already escaped spaces.
+ $self->{PERL} =~ tr/"//d if $Is{VMS};
# Are we building the core?
$self->{PERL_CORE} = $ENV{PERL_CORE} unless exists $self->{PERL_CORE};
foreach my $perl (qw(PERL FULLPERL ABSPERL)) {
my $run = $perl.'RUN';
- $self->{$run} = "\$($perl)";
+ $self->{$run} = qq{\$($perl)};
# Make sure perl can find itself before it's installed.
$self->{$run} .= q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"}
if $self->{UNINSTALLED_PERL} || $self->{PERL_CORE};
$self->{$perl.'RUNINST'} =
- sprintf q{$(%sRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"}, $perl;
+ sprintf q{$(%sRUN)%s "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"},
+ $perl, $perlflags;
}
return 1;
};
push @m,
-q{ read }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \
- write }.$self->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \
+q{ read "}.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \
+ write "}.$self->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \
} unless $self->{NO_PACKLIST};
push @m,
-q{ $(INST_LIB) $(DESTINSTALLPRIVLIB) \
- $(INST_ARCHLIB) $(DESTINSTALLARCHLIB) \
- $(INST_BIN) $(DESTINSTALLBIN) \
- $(INST_SCRIPT) $(DESTINSTALLSCRIPT) \
- $(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) \
- $(INST_MAN3DIR) $(DESTINSTALLMAN3DIR)
+q{ "$(INST_LIB)" "$(DESTINSTALLPRIVLIB)" \
+ "$(INST_ARCHLIB)" "$(DESTINSTALLARCHLIB)" \
+ "$(INST_BIN)" "$(DESTINSTALLBIN)" \
+ "$(INST_SCRIPT)" "$(DESTINSTALLSCRIPT)" \
+ "$(INST_MAN1DIR)" "$(DESTINSTALLMAN1DIR)" \
+ "$(INST_MAN3DIR)" "$(DESTINSTALLMAN3DIR)"
$(NOECHO) $(WARN_IF_OLD_PACKLIST) \
- }.$self->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{
+ "}.$self->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{"
pure_site_install :: all
$(NOECHO) $(MOD_INSTALL) \
};
push @m,
-q{ read }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{ \
- write }.$self->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{ \
+q{ read "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \
+ write "}.$self->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{" \
} unless $self->{NO_PACKLIST};
push @m,
-q{ $(INST_LIB) $(DESTINSTALLSITELIB) \
- $(INST_ARCHLIB) $(DESTINSTALLSITEARCH) \
- $(INST_BIN) $(DESTINSTALLSITEBIN) \
- $(INST_SCRIPT) $(DESTINSTALLSITESCRIPT) \
- $(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) \
- $(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR)
+q{ "$(INST_LIB)" "$(DESTINSTALLSITELIB)" \
+ "$(INST_ARCHLIB)" "$(DESTINSTALLSITEARCH)" \
+ "$(INST_BIN)" "$(DESTINSTALLSITEBIN)" \
+ "$(INST_SCRIPT)" "$(DESTINSTALLSITESCRIPT)" \
+ "$(INST_MAN1DIR)" "$(DESTINSTALLSITEMAN1DIR)" \
+ "$(INST_MAN3DIR)" "$(DESTINSTALLSITEMAN3DIR)"
$(NOECHO) $(WARN_IF_OLD_PACKLIST) \
- }.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{
+ "}.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{"
pure_vendor_install :: all
$(NOECHO) $(MOD_INSTALL) \
};
push @m,
-q{ read }.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{ \
- write }.$self->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').q{ \
+q{ read "}.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \
+ write "}.$self->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').q{" \
} unless $self->{NO_PACKLIST};
push @m,
-q{ $(INST_LIB) $(DESTINSTALLVENDORLIB) \
- $(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) \
- $(INST_BIN) $(DESTINSTALLVENDORBIN) \
- $(INST_SCRIPT) $(DESTINSTALLVENDORSCRIPT) \
- $(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) \
- $(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR)
+q{ "$(INST_LIB)" "$(DESTINSTALLVENDORLIB)" \
+ "$(INST_ARCHLIB)" "$(DESTINSTALLVENDORARCH)" \
+ "$(INST_BIN)" "$(DESTINSTALLVENDORBIN)" \
+ "$(INST_SCRIPT)" "$(DESTINSTALLVENDORSCRIPT)" \
+ "$(INST_MAN1DIR)" "$(DESTINSTALLVENDORMAN1DIR)" \
+ "$(INST_MAN3DIR)" "$(DESTINSTALLVENDORMAN3DIR)"
};
push @m, q{
doc_perl_install :: all
- $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
- -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
+ $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod"
+ -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
-$(NOECHO) $(DOC_INSTALL) \
"Module" "$(NAME)" \
- "installed into" "$(INSTALLPRIVLIB)" \
+ "installed into" $(INSTALLPRIVLIB) \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
- >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
+ >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
doc_site_install :: all
- $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
- -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
+ $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod"
+ -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
-$(NOECHO) $(DOC_INSTALL) \
"Module" "$(NAME)" \
- "installed into" "$(INSTALLSITELIB)" \
+ "installed into" $(INSTALLSITELIB) \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
- >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
+ >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
doc_vendor_install :: all
- $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
- -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
+ $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod"
+ -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
-$(NOECHO) $(DOC_INSTALL) \
"Module" "$(NAME)" \
- "installed into" "$(INSTALLVENDORLIB)" \
+ "installed into" $(INSTALLVENDORLIB) \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
EXE_FILES "$(EXE_FILES)" \
- >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
+ >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
} unless $self->{NO_PERLLOCAL};
$(NOECHO) $(NOOP)
uninstall_from_perldirs ::
- $(NOECHO) $(UNINSTALL) }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{
+ $(NOECHO) $(UNINSTALL) "}.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{"
uninstall_from_sitedirs ::
- $(NOECHO) $(UNINSTALL) }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{
+ $(NOECHO) $(UNINSTALL) "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{"
uninstall_from_vendordirs ::
- $(NOECHO) $(UNINSTALL) }.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{
+ $(NOECHO) $(UNINSTALL) "}.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{"
};
join("",@m);
$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) pm_to_blib
$(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET)
$(NOECHO) $(PERLRUNINST) \
- Makefile.PL DIR=}, $dir, q{ \
+ Makefile.PL DIR="}, $dir, q{" \
MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=};
-e "writemain(grep s#.*/auto/##s, split(q| |, q|$(MAP_STATIC)|))" > $@t && $(MV) $@t $@
};
- push @m, "\t", q{$(NOECHO) $(PERL) $(INSTALLSCRIPT)/fixpmain
+ push @m, "\t", q{$(NOECHO) $(PERL) "$(INSTALLSCRIPT)/fixpmain"
} if (defined (&Dos::UseLFN) && Dos::UseLFN()==0);
push @m, q{
doc_inst_perl :
- $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
- -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
+ $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod"
+ -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)"
-$(NOECHO) $(DOC_INSTALL) \
"Perl binary" "$(MAP_TARGET)" \
MAP_STATIC "$(MAP_STATIC)" \
MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \
MAP_LIBPERL "$(MAP_LIBPERL)" \
- >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
+ >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{"
};
inst_perl : pure_inst_perl doc_inst_perl
pure_inst_perl : $(MAP_TARGET)
- }.$self->{CP}.q{ $(MAP_TARGET) }.$self->catfile('$(DESTINSTALLBIN)','$(MAP_TARGET)').q{
+ }.$self->{CP}.q{ $(MAP_TARGET) "}.$self->catfile('$(DESTINSTALLBIN)','$(MAP_TARGET)').q{"
clean :: map_clean
local $/ = "\n";
open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!";
my $inpod = 0;
+ my $pod_encoding;
my $package = $self->{DISTNAME};
$package =~ s/-/::/g;
while (<$fh>) {
$inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
next if !$inpod;
chop;
+
+ if ( /^=encoding\s*(.*)$/i ) {
+ $pod_encoding = $1;
+ }
+
if ( /^($package(?:\.pm)? \s+ -+ \s+)(.*)/x ) {
$result = $2;
next;
}
next unless $result;
+
if ( $result && ( /^\s*$/ || /^\=/ ) ) {
last;
}
}
close $fh;
+ if ( $pod_encoding and !( $] < 5.008 or !$Config{useperlio} ) ) {
+ # Have to wrap in an eval{} for when running under PERL_CORE
+ # Encode isn't available during build phase and parsing
+ # ABSTRACT isn't important there
+ eval {
+ require Encode;
+ $result = Encode::decode($pod_encoding, $result);
+ }
+ }
+
return $result;
}
if ( defined $result && $result !~ /^v?[\d_\.]+$/ ) {
require version;
- my $normal = eval { version->parse( $result ) };
+ my $normal = eval { version->new( $result ) };
$result = $normal if defined $normal;
}
$result = "undef" unless defined $result;
return $result;
}
-sub get_version
-{
- my ($self, $parsefile, $sigil, $name) = @_;
- my $eval = qq{
- package ExtUtils::MakeMaker::_version;
- no strict;
- BEGIN { eval {
- # Ensure any version() routine which might have leaked
- # into this package has been deleted. Interferes with
- # version->import()
- undef *version;
- require version;
- "version"->import;
- } }
-
- local $sigil$name;
- \$$name=undef;
- do {
- $_
- };
- \$$name;
- };
- $eval = $1 if $eval =~ m{^(.+)}s;
- local $^W = 0;
- my $result = eval($eval); ## no critic
- warn "Could not eval '$eval' in $parsefile: $@" if $@;
- $result;
+sub get_version {
+ my ($self, $parsefile, $sigil, $name) = @_;
+ my $line = $_; # from the while() loop in parse_version
+ {
+ package ExtUtils::MakeMaker::_version;
+ undef *version; # in case of unexpected version() sub
+ eval {
+ require version;
+ version::->import;
+ };
+ no strict;
+ local *{$name};
+ local $^W = 0;
+ $line = $1 if $line =~ m{^(.+)}s;
+ eval($line); ## no critic
+ return ${$name};
+ }
}
-
=item pasthru (o)
Defines the string that is passed to recursive make calls in
# Check for unpropogated config.sh changes. Should never happen.
# We do NOT just update config.h because that is not sufficient.
# An out of date config.h is not fatal but complains loudly!
-$(PERL_INC)/config.h: $(PERL_SRC)/config.sh
+$(PERL_INCDEP)/config.h: $(PERL_SRC)/config.sh
-$(NOECHO) $(ECHO) "Warning: $(PERL_INC)/config.h out of date with $(PERL_SRC)/config.sh"; $(FALSE)
$(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh
push @m, $self->_perl_header_files_fragment("/"); # Directory separator between $(PERL_INC)/header.h
}
- push @m, join(" ", values %{$self->{XS}})." : \$(XSUBPPDEPS)\n" if %{$self->{XS}};
+ push @m, join(" ", sort values %{$self->{XS}})." : \$(XSUBPPDEPS)\n" if %{$self->{XS}};
return join "\n", @m;
}
foreach my $prereq (sort keys %prereqs) {
my $name = $prereq;
$name .= '::' unless $name =~ /::/;
- my $version = $prereqs{$prereq}+0; # force numification
+ my $version = $prereqs{$prereq};
my %attrs = ( NAME => $name );
$attrs{VERSION} = $version if $version;
- my $attrs = join " ", map { qq[$_="$attrs{$_}"] } keys %attrs;
+ my $attrs = join " ", map { qq[$_="$attrs{$_}"] } sort keys %attrs;
$ppd_xml .= qq( <REQUIRE $attrs />\n);
}
=item quote_literal
+Quotes macro literal value suitable for being used on a command line so
+that when expanded by make, will be received by command as given to
+this method:
+
+ my $quoted = $mm->quote_literal(q{it isn't});
+ # returns:
+ # 'it isn'\''t'
+ print MAKEFILE "target:\n\techo $quoted\n";
+ # when run "make target", will output:
+ # it isn't
+
=cut
sub quote_literal {
# If this extension has its own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push(@m, <<'MAKE_FRAG') if $self->{MYEXTLIB};
- $(CP) $(MYEXTLIB) $@
+ $(CP) $(MYEXTLIB) "$@"
MAKE_FRAG
my $ar;
push @m, sprintf <<'MAKE_FRAG', $ar;
$(%s) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@
$(CHMOD) $(PERM_RWX) $@
- $(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld
+ $(NOECHO) $(ECHO) "$(EXTRALIBS)" > "$(INST_ARCHAUTODIR)/extralibs.ld"
MAKE_FRAG
# Old mechanism - still available:
push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS};
- $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)/ext.libs
+ $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> "$(PERL_SRC)/ext.libs"
MAKE_FRAG
join('', @m);
elsif (!$tests && -d 't') {
$tests = $self->find_tests;
}
+ # have to do this because nmake is broken
+ $tests =~ s!/!\\!g if $self->is_make_type('nmake');
# note: 'test.pl' name is also hardcoded in init_dirscan()
my(@m);
push(@m,"
}
}
push(@tmdeps, "typemap") if -f "typemap";
- my(@tmargs) = map("-typemap $_", @tmdeps);
+ my @tmargs = map(qq{-typemap "$_"}, @tmdeps);
+ $_ = $self->quote_dep($_) for @tmdeps;
if( exists $self->{XSOPT} ){
unshift( @tmargs, $self->{XSOPT} );
}
$self->{XSPROTOARG} = "" unless defined $self->{XSPROTOARG};
+ my $xsdirdep = $self->quote_dep($xsdir);
+ # -dep for use when dependency not command
return qq{
XSUBPPDIR = $xsdir
-XSUBPP = \$(XSUBPPDIR)\$(DFSEP)xsubpp
+XSUBPP = "\$(XSUBPPDIR)\$(DFSEP)xsubpp"
XSUBPPRUN = \$(PERLRUN) \$(XSUBPP)
XSPROTOARG = $self->{XSPROTOARG}
-XSUBPPDEPS = @tmdeps \$(XSUBPP)
+XSUBPPDEPS = @tmdeps $xsdirdep\$(DFSEP)xsubpp
XSUBPPARGS = @tmargs
XSUBPP_EXTRA_ARGS =
};
-};
+}
=item all_target
use File::Basename;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
$ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}";
}
+ $self->{PERL_ARCHIVEDEP} ||= '';
$self->{PERL_ARCHIVE_AFTER} ||= '';
}
package ExtUtils::MM_VOS;
use strict;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
-our $VERSION = '6.98';
+our $VERSION = '7.02';
$ENV{EMXSHELL} = 'sh'; # to run `commands`
=item B<init_DIRFILESEP>
-Using \ for Windows.
+Using \ for Windows, except for "gmake" where it is /.
=cut
# The ^ makes sure its not interpreted as an escape in nmake
$self->{DIRFILESEP} = $self->is_make_type('nmake') ? '^\\' :
- $self->is_make_type('dmake') ? '\\\\'
+ $self->is_make_type('dmake') ? '\\\\' :
+ $self->is_make_type('gmake') ? '/'
: '\\';
}
$self->{DEV_NULL} ||= '> NUL';
$self->{FIXIN} ||= $self->{PERL_CORE} ?
- "\$(PERLRUN) $self->{PERL_SRC}/win32/bin/pl2bat.pl" :
+ "\$(PERLRUN) $self->{PERL_SRC}\\win32\\bin\\pl2bat.pl" :
'pl2bat.bat';
$self->SUPER::init_tools;
OTHERLDFLAGS = '.$otherldflags.'
INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
-$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
+$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVEDEP) $(INST_DYNAMIC_DEP)
');
if ($GCC) {
push(@m,
q{ }.$DLLTOOL.q{ --def $(EXPORT_LIST) --output-exp dll.exp
- $(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp
+ $(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) dll.exp
}.$DLLTOOL.q{ --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp
- $(LD) -o $@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp });
+ $(LD) -o $@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) dll.exp });
} elsif ($BORLAND) {
push(@m,
q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,}
.($self->is_make_type('dmake')
- ? q{$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) }
+ ? q{"$(PERL_ARCHIVE:s,/,\,)" $(LDLOADLIBS:s,/,\,) }
.q{$(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,)}
- : q{$(subst /,\,$(PERL_ARCHIVE)) $(subst /,\,$(LDLOADLIBS)) }
+ : q{"$(subst /,\,$(PERL_ARCHIVE))" $(subst /,\,$(LDLOADLIBS)) }
.q{$(subst /,\,$(MYEXTLIB)),$(subst /,\,$(EXPORT_LIST))})
.q{,$(RESFILES)});
} else { # VC
push(@m,
q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) }
- .q{$(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)});
+ .q{$(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -def:$(EXPORT_LIST)});
# Embed the manifest file if it exists
push(@m, q{
my $self = shift;
$self->{PERL_ARCHIVE} = "\$(PERL_INC)\\$Config{libperl}";
+ $self->{PERL_ARCHIVEDEP} = "\$(PERL_INCDEP)\\$Config{libperl}";
$self->{PERL_ARCHIVE_AFTER} = '';
$self->{EXPORT_LIST} = '$(BASEEXT).def';
}
return;
}
+sub can_dep_space {
+ my $self = shift;
+ 1; # with Win32::GetShortPathName
+}
+
+=item quote_dep
+
+=cut
+
+sub quote_dep {
+ my ($self, $arg) = @_;
+ if ($arg =~ / / and not $self->is_make_type('gmake')) {
+ require Win32;
+ $arg = Win32::GetShortPathName($arg);
+ die <<EOF if not defined $arg or $arg =~ / /;
+Tried to use make dependency with space for non-GNU make:
+ '$arg'
+Fallback to short pathname failed.
+EOF
+ return $arg;
+ }
+ return $self->SUPER::quote_dep($arg);
+}
=item xs_o
}
-sub is_make_type {
- my($self, $type) = @_;
- return !! ($self->make =~ /\b$type(?:\.exe)?$/);
-}
-
1;
__END__
=back
-
-=cut
-
-
use strict;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
require ExtUtils::MM_Win32;
our @ISA = qw(ExtUtils::MM_Win32);
use strict;
require ExtUtils::MM;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
our @ISA = qw(ExtUtils::MM);
{
require Exporter;
use ExtUtils::MakeMaker::Config;
+use ExtUtils::MakeMaker::version; # ensure we always have or fake version.pm
use Carp;
use File::Path;
+my $CAN_DECODE = eval { require ExtUtils::MakeMaker::Locale; }; # 2 birds, 1 stone
+eval { ExtUtils::MakeMaker::Locale::reinit('UTF-8') }
+ if $CAN_DECODE and $ExtUtils::MakeMaker::Locale::ENCODING_LOCALE eq 'US-ASCII';
our $Verbose = 0; # exported
our @Parent; # needs to be localized
our @Overridable;
my @Prepend_parent;
my %Recognized_Att_Keys;
+our %macro_fsentity; # whether a macro is a filesystem name
+our %macro_dep; # whether a macro is a dependency
-our $VERSION = '6.98';
+our $VERSION = '7.02';
$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval]
# Emulate something resembling CVS $Revision$
our $Filename = __FILE__; # referenced outside MakeMaker
our @ISA = qw(Exporter);
-our @EXPORT = qw(&WriteMakefile &writeMakefile $Verbose &prompt);
+our @EXPORT = qw(&WriteMakefile $Verbose &prompt);
our @EXPORT_OK = qw($VERSION &neatvalue &mkbootstrap &mksymlists
&WriteEmptyMakefile);
# purged.
my $Is_VMS = $^O eq 'VMS';
my $Is_Win32 = $^O eq 'MSWin32';
+my $UNDER_CORE = $ENV{PERL_CORE};
full_setup();
sub full_setup {
$Verbose ||= 0;
- my @attrib_help = qw/
+ my @dep_macros = qw/
+ PERL_INCDEP PERL_ARCHLIBDEP PERL_ARCHIVEDEP
+ /;
- AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION
- C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DISTVNAME
- DL_FUNCS DL_VARS
- EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE
- FULLPERL FULLPERLRUN FULLPERLRUNINST
- FUNCLIST H IMPORTS
+ my @fs_macros = qw/
+ FULLPERL XSUBPPDIR
INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB INST_MAN1DIR INST_MAN3DIR
INSTALLDIRS
PERL_LIB PERL_ARCHLIB
SITELIBEXP SITEARCHEXP
- INC INCLUDE_EXT LDFROM LIB LIBPERL_A LIBS LICENSE
- LINKTYPE MAKE MAKEAPERL MAKEFILE MAKEFILE_OLD MAN1PODS MAN3PODS MAP_TARGET
+ MAKE LIBPERL_A LIB PERL_SRC PERL_INC
+ PPM_INSTALL_EXEC PPM_UNINSTALL_EXEC
+ PPM_INSTALL_SCRIPT PPM_UNINSTALL_SCRIPT
+ /;
+
+ my @attrib_help = qw/
+
+ AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION
+ C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DISTVNAME
+ DL_FUNCS DL_VARS
+ EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE
+ FULLPERLRUN FULLPERLRUNINST
+ FUNCLIST H IMPORTS
+
+ INC INCLUDE_EXT LDFROM LIBS LICENSE
+ LINKTYPE MAKEAPERL MAKEFILE MAKEFILE_OLD MAN1PODS MAN3PODS MAP_TARGET
META_ADD META_MERGE MIN_PERL_VERSION BUILD_REQUIRES CONFIGURE_REQUIRES
MYEXTLIB NAME NEEDS_LINKING NOECHO NO_META NO_MYMETA NO_PACKLIST NO_PERLLOCAL
NORECURS NO_VC OBJECT OPTIMIZE PERL_MALLOC_OK PERL PERLMAINCC PERLRUN
PERLRUNINST PERL_CORE
- PERL_SRC PERM_DIR PERM_RW PERM_RWX MAGICXS
- PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE PPM_INSTALL_EXEC PPM_UNINSTALL_EXEC
- PPM_INSTALL_SCRIPT PPM_UNINSTALL_SCRIPT PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ
+ PERM_DIR PERM_RW PERM_RWX MAGICXS
+ PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE
+ PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ
SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST VERSION VERSION_FROM XS XSOPT XSPROTOARG
XS_VERSION clean depend dist dynamic_lib linkext macro realclean
tool_autosplit
+ MAN1EXT MAN3EXT
+
MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC
MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED
/;
+ push @attrib_help, @fs_macros;
+ @macro_fsentity{@fs_macros, @dep_macros} = (1) x (@fs_macros+@dep_macros);
+ @macro_dep{@dep_macros} = (1) x @dep_macros;
# IMPORTS is used under OS/2 and Win32
);
}
-sub writeMakefile {
- die <<END;
-
-The extension you are trying to build apparently is rather old and
-most probably outdated. We detect that from the fact, that a
-subroutine "writeMakefile" is called, and this subroutine is not
-supported anymore since about October 1994.
-
-Please contact the author or look into CPAN (details about CPAN can be
-found in the FAQ and at http:/www.perl.com) for a more recent version
-of the extension. If you're really desperate, you can try to change
-the subroutine name from writeMakefile to WriteMakefile and rerun
-'perl Makefile.PL', but you're most probably left alone, when you do
-so.
-
-The MakeMaker team
-
-END
-}
-
sub new {
my($class,$self) = @_;
my($key);
# simulate "use warnings FATAL => 'all'" for vintage perls
die @_;
};
- version->parse( $self->{MIN_PERL_VERSION} )
+ version->new( $self->{MIN_PERL_VERSION} )
};
$self->{MIN_PERL_VERSION} = $normal if defined $normal && !$@;
}
if ( defined $required_version && $required_version =~ /^v?[\d_\.]+$/
|| $required_version !~ /^v?[\d_\.]+$/ ) {
require version;
- my $normal = eval { version->parse( $required_version ) };
+ my $normal = eval { version->new( $required_version ) };
$required_version = $normal if defined $normal;
}
$installed_file = $prereq;
$self->{$key} = $self->{PARENT}{$key};
- unless ($Is_VMS && $key =~ /PERL$/) {
- $self->{$key} = $self->catdir("..",$self->{$key})
- unless $self->file_name_is_absolute($self->{$key});
- } else {
+ if ($Is_VMS && $key =~ /PERL$/) {
# PERL or FULLPERL will be a command verb or even a
# command with an argument instead of a full file
# specification under VMS. So, don't turn the command
$cmd[1] = $self->catfile('[-]',$cmd[1])
unless (@cmd < 2) || $self->file_name_is_absolute($cmd[1]);
$self->{$key} = join(' ', @cmd);
+ } else {
+ my $value = $self->{$key};
+ # not going to test in FS so only stripping start
+ $value =~ s/^"// if $key =~ /PERL$/;
+ $value = $self->catdir("..", $value)
+ unless $self->file_name_is_absolute($value);
+ $value = qq{"$value} if $key =~ /PERL$/;
+ $self->{$key} = $value;
}
}
if ($self->{PARENT}) {
foreach my $key (sort keys %$att){
next if $key eq 'ARGS';
- my ($v) = neatvalue($att->{$key});
+ my $v;
if ($key eq 'PREREQ_PM') {
# CPAN.pm takes prereqs from this field in 'Makefile'
# and does not know about BUILD_REQUIRES
sub parse_args{
my($self, @args) = @_;
+ @args = map { Encode::decode(locale => $_) } @args if $CAN_DECODE;
foreach (@args) {
unless (m/(.*?)=(.*)/) {
++$Verbose if m/^verb/;
unlink($finalname, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ());
open(my $fh,">", "MakeMaker.tmp")
or die "Unable to open MakeMaker.tmp: $!";
+ binmode $fh, ':encoding(locale)' if $CAN_DECODE;
for my $chunk (@{$self->{RESULT}}) {
+ my $to_write = "$chunk\n";
+ if (!$CAN_DECODE && $] > 5.008) {
+ utf8::encode $to_write;
+ }
print $fh "$chunk\n"
or die "Can't write to MakeMaker.tmp: $!";
}
push @m, "]";
return join "", @m;
}
- return "$v" unless $t eq 'HASH';
+ return $v unless $t eq 'HASH';
my(@m, $key, $val);
- while (($key,$val) = each %$v){
+ for my $key (sort keys %$v) {
last unless defined $key; # cautious programming in case (undef,undef) is true
- push(@m,"$key=>".neatvalue($val)) ;
+ push @m,"$key=>".neatvalue($v->{$key});
}
return "{ ".join(', ',@m)." }";
}
+sub _find_magic_vstring {
+ my $value = shift;
+ return $value if $UNDER_CORE;
+ 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;
+}
+
+
# Look for weird version numbers, warn about them and set them to 0
# before CPAN::Meta chokes.
sub clean_versions {
my($self, $key) = @_;
-
my $reqs = $self->{$key};
for my $module (keys %$reqs) {
- my $version = $reqs->{$module};
-
- if( !defined $version or $version !~ /^v?[\d_\.]+$/ ) {
- carp "Unparsable version '$version' for prerequisite $module";
+ my $v = $reqs->{$module};
+ my $printable = _find_magic_vstring($v);
+ $v = $printable if length $printable;
+ my $version = eval {
+ local $SIG{__WARN__} = sub {
+ # simulate "use warnings FATAL => 'all'" for vintage perls
+ die @_;
+ };
+ version->new($v)->stringify;
+ };
+ if( $@ || $reqs->{$module} eq '' ) {
+ if ( $] < 5.008 && $v !~ /^v?[\d_\.]+$/ ) {
+ $v = sprintf "v%vd", $v unless $v eq '';
+ }
+ carp "Unparsable version '$v' for prerequisite $module";
$reqs->{$module} = 0;
}
+ else {
+ $reqs->{$module} = $version;
+ }
}
}
using the wrong one.
On POSIX systems, that program will likely be GNU Make; on Microsoft
-Windows, it will be either Microsoft NMake or DMake. Note that this
-module does not support generating Makefiles for GNU Make on Windows.
+Windows, it will be either Microsoft NMake, DMake or GNU Make.
See the section on the L</"MAKE"> parameter for details.
-MakeMaker is object oriented. Each directory below the current
+ExtUtils::MakeMaker (EUMM) is object oriented. Each directory below the current
directory that contains a Makefile.PL is treated as a separate
object. This makes it possible to write an unlimited number of
Makefiles with a single invocation of WriteMakefile().
+All inputs to WriteMakefile are Unicode characters, not just octets. EUMM
+seeks to handle all of these correctly. It is currently still not possible
+to portably use Unicode characters in module names, because this requires
+Perl to handle Unicode filenames, which is not yet the case on Windows.
+
=head2 How To Write A Makefile.PL
See L<ExtUtils::MakeMaker::Tutorial>.
make test TEST_FILES='t/foobar.t t/dagobah*.t'
+Windows users who are using C<nmake> should note that due to a bug in C<nmake>,
+when specifying C<TEST_FILES> you must use back-slashes instead of forward-slashes.
+
+ nmake test TEST_FILES='t\foobar.t t\dagobah*.t'
+
=head2 make testdb
A useful variation of the above is the target C<testdb>. It runs the
Unless you want to override the defaults, prefer META_MERGE so as to
get the advantage of any future defaults.
+Where prereqs are concerned, if META_MERGE is used, prerequisites are merged
+with their counterpart C<WriteMakefile()> argument
+(PREREQ_PM is merged into {prereqs}{runtime}{requires},
+BUILD_REQUIRES into C<{prereqs}{build}{requires}>,
+CONFIGURE_REQUIRES into C<{prereqs}{configure}{requires}>,
+and TEST_REQUIRES into C<{prereqs}{test}{requires})>.
+When prereqs are specified with META_ADD, the only prerequisites added to the
+file come from the metadata, not C<WriteMakefile()> arguments.
+
+Note that these configuration options are only used for generating F<META.yml>
+and F<META.json> -- they are NOT used for F<MYMETA.yml> and F<MYMETA.json>.
+Therefore data in these fields should NOT be used for dynamic (user-side)
+configuration.
+
By default CPAN Meta specification C<1.4> is used. In order to use
CPAN Meta specification C<2.0>, indicate with C<meta-spec> the version
you want to use.
The package representing the distribution. For example, C<Test::More>
or C<ExtUtils::MakeMaker>. It will be used to derive information about
-the distribution such as the L<DISTNAME>, installation locations
+the distribution such as the L</DISTNAME>, installation locations
within the Perl library and where XS files will be looked for by
-default (see L<XS>).
+default (see L</XS>).
C<NAME> I<must> be a valid Perl package name and it I<must> have an
associated C<.pm> file. For example, C<Foo::Bar> is a valid C<NAME>
=back
+=head2 Supported versions of Perl
+
+Please note that while this module works on Perl 5.6, it is no longer
+being routinely tested on 5.6 - the earliest Perl version being routinely
+tested, and expressly supported, is 5.8.1. However, patches to repair
+any breakage on 5.6 are still being accepted.
=head1 ENVIRONMENT
L<CPAN::Meta> and L<CPAN::Meta::Spec> explain CPAN Meta files in detail.
+L<File::ShareDir::Install> makes it easy to install static, sometimes
+also referred to as 'shared' files. L<File::ShareDir> helps accessing
+the shared files after installation.
+
+L<Dist::Zilla> makes it easy for the module author to create MakeMaker-based
+distributions with lots of bells and whistles.
+
=head1 AUTHORS
Andy Dougherty C<doughera@lafayette.edu>, Andreas KE<ouml>nig
use strict;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
use Config ();
package ExtUtils::MakeMaker::FAQ;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
1;
__END__
--- /dev/null
+package ExtUtils::MakeMaker::Locale;
+
+use strict;
+our $VERSION = "7.02";
+
+use base 'Exporter';
+our @EXPORT_OK = qw(
+ decode_argv env
+ $ENCODING_LOCALE $ENCODING_LOCALE_FS
+ $ENCODING_CONSOLE_IN $ENCODING_CONSOLE_OUT
+);
+
+use Encode ();
+use Encode::Alias ();
+
+our $ENCODING_LOCALE;
+our $ENCODING_LOCALE_FS;
+our $ENCODING_CONSOLE_IN;
+our $ENCODING_CONSOLE_OUT;
+
+sub DEBUG () { 0 }
+
+sub _init {
+ if ($^O eq "MSWin32") {
+ unless ($ENCODING_LOCALE) {
+ # Try to obtain what the Windows ANSI code page is
+ eval {
+ unless (defined &GetACP) {
+ require Win32::API;
+ Win32::API->Import('kernel32', 'int GetACP()');
+ };
+ if (defined &GetACP) {
+ my $cp = GetACP();
+ $ENCODING_LOCALE = "cp$cp" if $cp;
+ }
+ };
+ }
+
+ unless ($ENCODING_CONSOLE_IN) {
+ # If we have the Win32::Console module installed we can ask
+ # it for the code set to use
+ eval {
+ require Win32::Console;
+ my $cp = Win32::Console::InputCP();
+ $ENCODING_CONSOLE_IN = "cp$cp" if $cp;
+ $cp = Win32::Console::OutputCP();
+ $ENCODING_CONSOLE_OUT = "cp$cp" if $cp;
+ };
+ # Invoking the 'chcp' program might also work
+ if (!$ENCODING_CONSOLE_IN && (qx(chcp) || '') =~ /^Active code page: (\d+)/) {
+ $ENCODING_CONSOLE_IN = "cp$1";
+ }
+ }
+ }
+
+ unless ($ENCODING_LOCALE) {
+ eval {
+ require I18N::Langinfo;
+ $ENCODING_LOCALE = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET());
+
+ # Workaround of Encode < v2.25. The "646" encoding alias was
+ # introduced in Encode-2.25, but we don't want to require that version
+ # quite yet. Should avoid the CPAN testers failure reported from
+ # openbsd-4.7/perl-5.10.0 combo.
+ $ENCODING_LOCALE = "ascii" if $ENCODING_LOCALE eq "646";
+
+ # https://rt.cpan.org/Ticket/Display.html?id=66373
+ $ENCODING_LOCALE = "hp-roman8" if $^O eq "hpux" && $ENCODING_LOCALE eq "roman8";
+ };
+ $ENCODING_LOCALE ||= $ENCODING_CONSOLE_IN;
+ }
+
+ if ($^O eq "darwin") {
+ $ENCODING_LOCALE_FS ||= "UTF-8";
+ }
+
+ # final fallback
+ $ENCODING_LOCALE ||= $^O eq "MSWin32" ? "cp1252" : "UTF-8";
+ $ENCODING_LOCALE_FS ||= $ENCODING_LOCALE;
+ $ENCODING_CONSOLE_IN ||= $ENCODING_LOCALE;
+ $ENCODING_CONSOLE_OUT ||= $ENCODING_CONSOLE_IN;
+
+ unless (Encode::find_encoding($ENCODING_LOCALE)) {
+ my $foundit;
+ if (lc($ENCODING_LOCALE) eq "gb18030") {
+ eval {
+ require Encode::HanExtra;
+ };
+ if ($@) {
+ die "Need Encode::HanExtra to be installed to support locale codeset ($ENCODING_LOCALE), stopped";
+ }
+ $foundit++ if Encode::find_encoding($ENCODING_LOCALE);
+ }
+ die "The locale codeset ($ENCODING_LOCALE) isn't one that perl can decode, stopped"
+ unless $foundit;
+
+ }
+
+ # use Data::Dump; ddx $ENCODING_LOCALE, $ENCODING_LOCALE_FS, $ENCODING_CONSOLE_IN, $ENCODING_CONSOLE_OUT;
+}
+
+_init();
+Encode::Alias::define_alias(sub {
+ no strict 'refs';
+ no warnings 'once';
+ return ${"ENCODING_" . uc(shift)};
+}, "locale");
+
+sub _flush_aliases {
+ no strict 'refs';
+ for my $a (keys %Encode::Alias::Alias) {
+ if (defined ${"ENCODING_" . uc($a)}) {
+ delete $Encode::Alias::Alias{$a};
+ warn "Flushed alias cache for $a" if DEBUG;
+ }
+ }
+}
+
+sub reinit {
+ $ENCODING_LOCALE = shift;
+ $ENCODING_LOCALE_FS = shift;
+ $ENCODING_CONSOLE_IN = $ENCODING_LOCALE;
+ $ENCODING_CONSOLE_OUT = $ENCODING_LOCALE;
+ _init();
+ _flush_aliases();
+}
+
+sub decode_argv {
+ die if defined wantarray;
+ for (@ARGV) {
+ $_ = Encode::decode(locale => $_, @_);
+ }
+}
+
+sub env {
+ my $k = Encode::encode(locale => shift);
+ my $old = $ENV{$k};
+ if (@_) {
+ my $v = shift;
+ if (defined $v) {
+ $ENV{$k} = Encode::encode(locale => $v);
+ }
+ else {
+ delete $ENV{$k};
+ }
+ }
+ return Encode::decode(locale => $old) if defined wantarray;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::MakeMaker::Locale - bundled Encode::Locale
+
+=head1 SYNOPSIS
+
+ use Encode::Locale;
+ use Encode;
+
+ $string = decode(locale => $bytes);
+ $bytes = encode(locale => $string);
+
+ if (-t) {
+ binmode(STDIN, ":encoding(console_in)");
+ binmode(STDOUT, ":encoding(console_out)");
+ binmode(STDERR, ":encoding(console_out)");
+ }
+
+ # Processing file names passed in as arguments
+ my $uni_filename = decode(locale => $ARGV[0]);
+ open(my $fh, "<", encode(locale_fs => $uni_filename))
+ || die "Can't open '$uni_filename': $!";
+ binmode($fh, ":encoding(locale)");
+ ...
+
+=head1 DESCRIPTION
+
+In many applications it's wise to let Perl use Unicode for the strings it
+processes. Most of the interfaces Perl has to the outside world are still byte
+based. Programs therefore need to decode byte strings that enter the program
+from the outside and encode them again on the way out.
+
+The POSIX locale system is used to specify both the language conventions
+requested by the user and the preferred character set to consume and
+output. The C<Encode::Locale> module looks up the charset and encoding (called
+a CODESET in the locale jargon) and arranges for the L<Encode> module to know
+this encoding under the name "locale". It means bytes obtained from the
+environment can be converted to Unicode strings by calling C<<
+Encode::encode(locale => $bytes) >> and converted back again with C<<
+Encode::decode(locale => $string) >>.
+
+Where file systems interfaces pass file names in and out of the program we also
+need care. The trend is for operating systems to use a fixed file encoding
+that don't actually depend on the locale; and this module determines the most
+appropriate encoding for file names. The L<Encode> module will know this
+encoding under the name "locale_fs". For traditional Unix systems this will
+be an alias to the same encoding as "locale".
+
+For programs running in a terminal window (called a "Console" on some systems)
+the "locale" encoding is usually a good choice for what to expect as input and
+output. Some systems allows us to query the encoding set for the terminal and
+C<Encode::Locale> will do that if available and make these encodings known
+under the C<Encode> aliases "console_in" and "console_out". For systems where
+we can't determine the terminal encoding these will be aliased as the same
+encoding as "locale". The advice is to use "console_in" for input known to
+come from the terminal and "console_out" for output known to go from the
+terminal.
+
+In addition to arranging for various Encode aliases the following functions and
+variables are provided:
+
+=over
+
+=item decode_argv( )
+
+=item decode_argv( Encode::FB_CROAK )
+
+This will decode the command line arguments to perl (the C<@ARGV> array) in-place.
+
+The function will by default replace characters that can't be decoded by
+"\x{FFFD}", the Unicode replacement character.
+
+Any argument provided is passed as CHECK to underlying Encode::decode() call.
+Pass the value C<Encode::FB_CROAK> to have the decoding croak if not all the
+command line arguments can be decoded. See L<Encode/"Handling Malformed Data">
+for details on other options for CHECK.
+
+=item env( $uni_key )
+
+=item env( $uni_key => $uni_value )
+
+Interface to get/set environment variables. Returns the current value as a
+Unicode string. The $uni_key and $uni_value arguments are expected to be
+Unicode strings as well. Passing C<undef> as $uni_value deletes the
+environment variable named $uni_key.
+
+The returned value will have the characters that can't be decoded replaced by
+"\x{FFFD}", the Unicode replacement character.
+
+There is no interface to request alternative CHECK behavior as for
+decode_argv(). If you need that you need to call encode/decode yourself.
+For example:
+
+ my $key = Encode::encode(locale => $uni_key, Encode::FB_CROAK);
+ my $uni_value = Encode::decode(locale => $ENV{$key}, Encode::FB_CROAK);
+
+=item reinit( )
+
+=item reinit( $encoding )
+
+Reinitialize the encodings from the locale. You want to call this function if
+you changed anything in the environment that might influence the locale.
+
+This function will croak if the determined encoding isn't recognized by
+the Encode module.
+
+With argument force $ENCODING_... variables to set to the given value.
+
+=item $ENCODING_LOCALE
+
+The encoding name determined to be suitable for the current locale.
+L<Encode> know this encoding as "locale".
+
+=item $ENCODING_LOCALE_FS
+
+The encoding name determined to be suiteable for file system interfaces
+involving file names.
+L<Encode> know this encoding as "locale_fs".
+
+=item $ENCODING_CONSOLE_IN
+
+=item $ENCODING_CONSOLE_OUT
+
+The encodings to be used for reading and writing output to the a console.
+L<Encode> know these encodings as "console_in" and "console_out".
+
+=back
+
+=head1 NOTES
+
+This table summarizes the mapping of the encodings set up
+by the C<Encode::Locale> module:
+
+ Encode | | |
+ Alias | Windows | Mac OS X | POSIX
+ ------------+---------+--------------+------------
+ locale | ANSI | nl_langinfo | nl_langinfo
+ locale_fs | ANSI | UTF-8 | nl_langinfo
+ console_in | OEM | nl_langinfo | nl_langinfo
+ console_out | OEM | nl_langinfo | nl_langinfo
+
+=head2 Windows
+
+Windows has basically 2 sets of APIs. A wide API (based on passing UTF-16
+strings) and a byte based API based a character set called ANSI. The
+regular Perl interfaces to the OS currently only uses the ANSI APIs.
+Unfortunately ANSI is not a single character set.
+
+The encoding that corresponds to ANSI varies between different editions of
+Windows. For many western editions of Windows ANSI corresponds to CP-1252
+which is a character set similar to ISO-8859-1. Conceptually the ANSI
+character set is a similar concept to the POSIX locale CODESET so this module
+figures out what the ANSI code page is and make this available as
+$ENCODING_LOCALE and the "locale" Encoding alias.
+
+Windows systems also operate with another byte based character set.
+It's called the OEM code page. This is the encoding that the Console
+takes as input and output. It's common for the OEM code page to
+differ from the ANSI code page.
+
+=head2 Mac OS X
+
+On Mac OS X the file system encoding is always UTF-8 while the locale
+can otherwise be set up as normal for POSIX systems.
+
+File names on Mac OS X will at the OS-level be converted to
+NFD-form. A file created by passing a NFC-filename will come
+in NFD-form from readdir(). See L<Unicode::Normalize> for details
+of NFD/NFC.
+
+Actually, Apple does not follow the Unicode NFD standard since not all
+character ranges are decomposed. The claim is that this avoids problems with
+round trip conversions from old Mac text encodings. See L<Encode::UTF8Mac> for
+details.
+
+=head2 POSIX (Linux and other Unixes)
+
+File systems might vary in what encoding is to be used for
+filenames. Since this module has no way to actually figure out
+what the is correct it goes with the best guess which is to
+assume filenames are encoding according to the current locale.
+Users are advised to always specify UTF-8 as the locale charset.
+
+=head1 SEE ALSO
+
+L<I18N::Langinfo>, L<Encode>
+
+=head1 AUTHOR
+
+Copyright 2010 Gisle Aas <gisle@aas.no>.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
package ExtUtils::MakeMaker::Tutorial;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
=head1 NAME
--- /dev/null
+#--------------------------------------------------------------------------#
+# This is a modified copy of version.pm 0.9909, bundled exclusively for
+# use by ExtUtils::Makemaker and its dependencies to bootstrap when
+# version.pm is not available. It should not be used by ordinary modules.
+#
+# When loaded, it will try to load version.pm. If that fails, it will load
+# ExtUtils::MakeMaker::version::vpp and alias various *version functions
+# to functions in that module. It will also override UNIVERSAL::VERSION.
+#--------------------------------------------------------------------------#
+
+package ExtUtils::MakeMaker::version;
+
+use 5.006002;
+use strict;
+
+use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
+
+$VERSION = '7.02';
+$CLASS = 'version';
+
+{
+ local $SIG{'__DIE__'};
+ eval "use version";
+ if ( $@ ) { # don't have any version.pm installed
+ eval "use ExtUtils::MakeMaker::version::vpp";
+ die "$@" if ( $@ );
+ local $^W;
+ delete $INC{'version.pm'};
+ $INC{'version.pm'} = $INC{'ExtUtils/MakeMaker/version.pm'};
+ push @version::ISA, "ExtUtils::MakeMaker::version::vpp";
+ $version::VERSION = $VERSION;
+ *version::qv = \&ExtUtils::MakeMaker::version::vpp::qv;
+ *version::declare = \&ExtUtils::MakeMaker::version::vpp::declare;
+ *version::_VERSION = \&ExtUtils::MakeMaker::version::vpp::_VERSION;
+ *version::vcmp = \&ExtUtils::MakeMaker::version::vpp::vcmp;
+ *version::new = \&ExtUtils::MakeMaker::version::vpp::new;
+ if ($] >= 5.009000) {
+ no strict 'refs';
+ *version::stringify = \&ExtUtils::MakeMaker::version::vpp::stringify;
+ *{'version::(""'} = \&ExtUtils::MakeMaker::version::vpp::stringify;
+ *{'version::(<=>'} = \&ExtUtils::MakeMaker::version::vpp::vcmp;
+ *version::parse = \&ExtUtils::MakeMaker::version::vpp::parse;
+ }
+ require ExtUtils::MakeMaker::version::regex;
+ *version::is_lax = \&ExtUtils::MakeMaker::version::regex::is_lax;
+ *version::is_strict = \&ExtUtils::MakeMaker::version::regex::is_strict;
+ *LAX = \$ExtUtils::MakeMaker::version::regex::LAX;
+ *STRICT = \$ExtUtils::MakeMaker::version::regex::STRICT;
+ }
+ elsif ( ! version->can('is_qv') ) {
+ *version::is_qv = sub { exists $_[0]->{qv} };
+ }
+}
+
+1;
--- /dev/null
+#--------------------------------------------------------------------------#
+# This is a modified copy of version.pm 0.9909, bundled exclusively for
+# use by ExtUtils::Makemaker and its dependencies to bootstrap when
+# version.pm is not available. It should not be used by ordinary modules.
+#--------------------------------------------------------------------------#
+
+package ExtUtils::MakeMaker::version::regex;
+
+use strict;
+
+use vars qw($VERSION $CLASS $STRICT $LAX);
+
+$VERSION = '7.02';
+
+#--------------------------------------------------------------------------#
+# Version regexp components
+#--------------------------------------------------------------------------#
+
+# Fraction part of a decimal version number. This is a common part of
+# both strict and lax decimal versions
+
+my $FRACTION_PART = qr/\.[0-9]+/;
+
+# First part of either decimal or dotted-decimal strict version number.
+# Unsigned integer with no leading zeroes (except for zero itself) to
+# avoid confusion with octal.
+
+my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/;
+
+# First part of either decimal or dotted-decimal lax version number.
+# Unsigned integer, but allowing leading zeros. Always interpreted
+# as decimal. However, some forms of the resulting syntax give odd
+# results if used as ordinary Perl expressions, due to how perl treats
+# octals. E.g.
+# version->new("010" ) == 10
+# version->new( 010 ) == 8
+# version->new( 010.2) == 82 # "8" . "2"
+
+my $LAX_INTEGER_PART = qr/[0-9]+/;
+
+# Second and subsequent part of a strict dotted-decimal version number.
+# Leading zeroes are permitted, and the number is always decimal.
+# Limited to three digits to avoid overflow when converting to decimal
+# form and also avoid problematic style with excessive leading zeroes.
+
+my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;
+
+# Second and subsequent part of a lax dotted-decimal version number.
+# Leading zeroes are permitted, and the number is always decimal. No
+# limit on the numerical value or number of digits, so there is the
+# possibility of overflow when converting to decimal form.
+
+my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;
+
+# Alpha suffix part of lax version number syntax. Acts like a
+# dotted-decimal part.
+
+my $LAX_ALPHA_PART = qr/_[0-9]+/;
+
+#--------------------------------------------------------------------------#
+# Strict version regexp definitions
+#--------------------------------------------------------------------------#
+
+# Strict decimal version number.
+
+my $STRICT_DECIMAL_VERSION =
+ qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;
+
+# Strict dotted-decimal version number. Must have both leading "v" and
+# at least three parts, to avoid confusion with decimal syntax.
+
+my $STRICT_DOTTED_DECIMAL_VERSION =
+ qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;
+
+# Complete strict version number syntax -- should generally be used
+# anchored: qr/ \A $STRICT \z /x
+
+$STRICT =
+ qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;
+
+#--------------------------------------------------------------------------#
+# Lax version regexp definitions
+#--------------------------------------------------------------------------#
+
+# Lax decimal version number. Just like the strict one except for
+# allowing an alpha suffix or allowing a leading or trailing
+# decimal-point
+
+my $LAX_DECIMAL_VERSION =
+ qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
+ |
+ $FRACTION_PART $LAX_ALPHA_PART?
+ /x;
+
+# Lax dotted-decimal version number. Distinguished by having either
+# leading "v" or at least three non-alpha parts. Alpha part is only
+# permitted if there are at least two non-alpha parts. Strangely
+# enough, without the leading "v", Perl takes .1.2 to mean v0.1.2,
+# so when there is no "v", the leading part is optional
+
+my $LAX_DOTTED_DECIMAL_VERSION =
+ qr/
+ v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
+ |
+ $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
+ /x;
+
+# Complete lax version number syntax -- should generally be used
+# anchored: qr/ \A $LAX \z /x
+#
+# The string 'undef' is a special case to make for easier handling
+# of return values from ExtUtils::MM->parse_version
+
+$LAX =
+ qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;
+
+#--------------------------------------------------------------------------#
+
+# Preloaded methods go here.
+sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
+sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
+
+1;
--- /dev/null
+#--------------------------------------------------------------------------#
+# This is a modified copy of version.pm 0.9909, bundled exclusively for
+# use by ExtUtils::Makemaker and its dependencies to bootstrap when
+# version.pm is not available. It should not be used by ordinary modules.
+#--------------------------------------------------------------------------#
+
+package ExtUtils::MakeMaker::charstar;
+# a little helper class to emulate C char* semantics in Perl
+# so that prescan_version can use the same code as in C
+
+use overload (
+ '""' => \&thischar,
+ '0+' => \&thischar,
+ '++' => \&increment,
+ '--' => \&decrement,
+ '+' => \&plus,
+ '-' => \&minus,
+ '*' => \&multiply,
+ 'cmp' => \&cmp,
+ '<=>' => \&spaceship,
+ 'bool' => \&thischar,
+ '=' => \&clone,
+);
+
+sub new {
+ my ($self, $string) = @_;
+ my $class = ref($self) || $self;
+
+ my $obj = {
+ string => [split(//,$string)],
+ current => 0,
+ };
+ return bless $obj, $class;
+}
+
+sub thischar {
+ my ($self) = @_;
+ my $last = $#{$self->{string}};
+ my $curr = $self->{current};
+ if ($curr >= 0 && $curr <= $last) {
+ return $self->{string}->[$curr];
+ }
+ else {
+ return '';
+ }
+}
+
+sub increment {
+ my ($self) = @_;
+ $self->{current}++;
+}
+
+sub decrement {
+ my ($self) = @_;
+ $self->{current}--;
+}
+
+sub plus {
+ my ($self, $offset) = @_;
+ my $rself = $self->clone;
+ $rself->{current} += $offset;
+ return $rself;
+}
+
+sub minus {
+ my ($self, $offset) = @_;
+ my $rself = $self->clone;
+ $rself->{current} -= $offset;
+ return $rself;
+}
+
+sub multiply {
+ my ($left, $right, $swapped) = @_;
+ my $char = $left->thischar();
+ return $char * $right;
+}
+
+sub spaceship {
+ my ($left, $right, $swapped) = @_;
+ unless (ref($right)) { # not an object already
+ $right = $left->new($right);
+ }
+ return $left->{current} <=> $right->{current};
+}
+
+sub cmp {
+ my ($left, $right, $swapped) = @_;
+ unless (ref($right)) { # not an object already
+ if (length($right) == 1) { # comparing single character only
+ return $left->thischar cmp $right;
+ }
+ $right = $left->new($right);
+ }
+ return $left->currstr cmp $right->currstr;
+}
+
+sub bool {
+ my ($self) = @_;
+ my $char = $self->thischar;
+ return ($char ne '');
+}
+
+sub clone {
+ my ($left, $right, $swapped) = @_;
+ $right = {
+ string => [@{$left->{string}}],
+ current => $left->{current},
+ };
+ return bless $right, ref($left);
+}
+
+sub currstr {
+ my ($self, $s) = @_;
+ my $curr = $self->{current};
+ my $last = $#{$self->{string}};
+ if (defined($s) && $s->{current} < $last) {
+ $last = $s->{current};
+ }
+
+ my $string = join('', @{$self->{string}}[$curr..$last]);
+ return $string;
+}
+
+package ExtUtils::MakeMaker::version::vpp;
+
+use 5.006002;
+use strict;
+
+use Config;
+use vars qw($VERSION $CLASS @ISA $LAX $STRICT);
+$VERSION = '7.02';
+$CLASS = 'ExtUtils::MakeMaker::version::vpp';
+
+require ExtUtils::MakeMaker::version::regex;
+*ExtUtils::MakeMaker::version::vpp::is_strict = \&ExtUtils::MakeMaker::version::regex::is_strict;
+*ExtUtils::MakeMaker::version::vpp::is_lax = \&ExtUtils::MakeMaker::version::regex::is_lax;
+*LAX = \$ExtUtils::MakeMaker::version::regex::LAX;
+*STRICT = \$ExtUtils::MakeMaker::version::regex::STRICT;
+
+use overload (
+ '""' => \&stringify,
+ '0+' => \&numify,
+ 'cmp' => \&vcmp,
+ '<=>' => \&vcmp,
+ 'bool' => \&vbool,
+ '+' => \&vnoop,
+ '-' => \&vnoop,
+ '*' => \&vnoop,
+ '/' => \&vnoop,
+ '+=' => \&vnoop,
+ '-=' => \&vnoop,
+ '*=' => \&vnoop,
+ '/=' => \&vnoop,
+ 'abs' => \&vnoop,
+);
+
+eval "use warnings";
+if ($@) {
+ eval '
+ package
+ warnings;
+ sub enabled {return $^W;}
+ 1;
+ ';
+}
+
+sub import {
+ no strict 'refs';
+ my ($class) = shift;
+
+ # Set up any derived class
+ unless ($class eq $CLASS) {
+ local $^W;
+ *{$class.'::declare'} = \&{$CLASS.'::declare'};
+ *{$class.'::qv'} = \&{$CLASS.'::qv'};
+ }
+
+ my %args;
+ if (@_) { # any remaining terms are arguments
+ map { $args{$_} = 1 } @_
+ }
+ else { # no parameters at all on use line
+ %args =
+ (
+ qv => 1,
+ 'UNIVERSAL::VERSION' => 1,
+ );
+ }
+
+ my $callpkg = caller();
+
+ if (exists($args{declare})) {
+ *{$callpkg.'::declare'} =
+ sub {return $class->declare(shift) }
+ unless defined(&{$callpkg.'::declare'});
+ }
+
+ if (exists($args{qv})) {
+ *{$callpkg.'::qv'} =
+ sub {return $class->qv(shift) }
+ unless defined(&{$callpkg.'::qv'});
+ }
+
+ if (exists($args{'UNIVERSAL::VERSION'})) {
+ local $^W;
+ *UNIVERSAL::VERSION
+ = \&{$CLASS.'::_VERSION'};
+ }
+
+ if (exists($args{'VERSION'})) {
+ *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'};
+ }
+
+ if (exists($args{'is_strict'})) {
+ *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'}
+ unless defined(&{$callpkg.'::is_strict'});
+ }
+
+ if (exists($args{'is_lax'})) {
+ *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'}
+ unless defined(&{$callpkg.'::is_lax'});
+ }
+}
+
+my $VERSION_MAX = 0x7FFFFFFF;
+
+# implement prescan_version as closely to the C version as possible
+use constant TRUE => 1;
+use constant FALSE => 0;
+
+sub isDIGIT {
+ my ($char) = shift->thischar();
+ return ($char =~ /\d/);
+}
+
+sub isALPHA {
+ my ($char) = shift->thischar();
+ return ($char =~ /[a-zA-Z]/);
+}
+
+sub isSPACE {
+ my ($char) = shift->thischar();
+ return ($char =~ /\s/);
+}
+
+sub BADVERSION {
+ my ($s, $errstr, $error) = @_;
+ if ($errstr) {
+ $$errstr = $error;
+ }
+ return $s;
+}
+
+sub prescan_version {
+ my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_;
+ my $qv = defined $sqv ? $$sqv : FALSE;
+ my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0;
+ my $width = defined $swidth ? $$swidth : 3;
+ my $alpha = defined $salpha ? $$salpha : FALSE;
+
+ my $d = $s;
+
+ if ($qv && isDIGIT($d)) {
+ goto dotted_decimal_version;
+ }
+
+ if ($d eq 'v') { # explicit v-string
+ $d++;
+ if (isDIGIT($d)) {
+ $qv = TRUE;
+ }
+ else { # degenerate v-string
+ # requires v1.2.3
+ return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+
+dotted_decimal_version:
+ if ($strict && $d eq '0' && isDIGIT($d+1)) {
+ # no leading zeros allowed
+ return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
+ }
+
+ while (isDIGIT($d)) { # integer part
+ $d++;
+ }
+
+ if ($d eq '.')
+ {
+ $saw_decimal++;
+ $d++; # decimal point
+ }
+ else
+ {
+ if ($strict) {
+ # require v1.2.3
+ return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ else {
+ goto version_prescan_finish;
+ }
+ }
+
+ {
+ my $i = 0;
+ my $j = 0;
+ while (isDIGIT($d)) { # just keep reading
+ $i++;
+ while (isDIGIT($d)) {
+ $d++; $j++;
+ # maximum 3 digits between decimal
+ if ($strict && $j > 3) {
+ return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)");
+ }
+ }
+ if ($d eq '_') {
+ if ($strict) {
+ return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
+ }
+ if ( $alpha ) {
+ return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
+ }
+ $d++;
+ $alpha = TRUE;
+ }
+ elsif ($d eq '.') {
+ if ($alpha) {
+ return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
+ }
+ $saw_decimal++;
+ $d++;
+ }
+ elsif (!isDIGIT($d)) {
+ last;
+ }
+ $j = 0;
+ }
+
+ if ($strict && $i < 2) {
+ # requires v1.2.3
+ return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
+ }
+ }
+ } # end if dotted-decimal
+ else
+ { # decimal versions
+ my $j = 0;
+ # special $strict case for leading '.' or '0'
+ if ($strict) {
+ if ($d eq '.') {
+ return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)");
+ }
+ if ($d eq '0' && isDIGIT($d+1)) {
+ return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
+ }
+ }
+
+ # and we never support negative version numbers
+ if ($d eq '-') {
+ return BADVERSION($s,$errstr,"Invalid version format (negative version number)");
+ }
+
+ # consume all of the integer part
+ while (isDIGIT($d)) {
+ $d++;
+ }
+
+ # look for a fractional part
+ if ($d eq '.') {
+ # we found it, so consume it
+ $saw_decimal++;
+ $d++;
+ }
+ elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') {
+ if ( $d == $s ) {
+ # found nothing
+ return BADVERSION($s,$errstr,"Invalid version format (version required)");
+ }
+ # found just an integer
+ goto version_prescan_finish;
+ }
+ elsif ( $d == $s ) {
+ # didn't find either integer or period
+ return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
+ }
+ elsif ($d eq '_') {
+ # underscore can't come after integer part
+ if ($strict) {
+ return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
+ }
+ elsif (isDIGIT($d+1)) {
+ return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)");
+ }
+ else {
+ return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
+ }
+ }
+ elsif ($d) {
+ # anything else after integer part is just invalid data
+ return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
+ }
+
+ # scan the fractional part after the decimal point
+ if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) {
+ # $strict or lax-but-not-the-end
+ return BADVERSION($s,$errstr,"Invalid version format (fractional part required)");
+ }
+
+ while (isDIGIT($d)) {
+ $d++; $j++;
+ if ($d eq '.' && isDIGIT($d-1)) {
+ if ($alpha) {
+ return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
+ }
+ if ($strict) {
+ return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
+ }
+ $d = $s; # start all over again
+ $qv = TRUE;
+ goto dotted_decimal_version;
+ }
+ if ($d eq '_') {
+ if ($strict) {
+ return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
+ }
+ if ( $alpha ) {
+ return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
+ }
+ if ( ! isDIGIT($d+1) ) {
+ return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
+ }
+ $width = $j;
+ $d++;
+ $alpha = TRUE;
+ }
+ }
+ }
+
+version_prescan_finish:
+ while (isSPACE($d)) {
+ $d++;
+ }
+
+ if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) {
+ # trailing non-numeric data
+ return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
+ }
+
+ if (defined $sqv) {
+ $$sqv = $qv;
+ }
+ if (defined $swidth) {
+ $$swidth = $width;
+ }
+ if (defined $ssaw_decimal) {
+ $$ssaw_decimal = $saw_decimal;
+ }
+ if (defined $salpha) {
+ $$salpha = $alpha;
+ }
+ return $d;
+}
+
+sub scan_version {
+ my ($s, $rv, $qv) = @_;
+ my $start;
+ my $pos;
+ my $last;
+ my $errstr;
+ my $saw_decimal = 0;
+ my $width = 3;
+ my $alpha = FALSE;
+ my $vinf = FALSE;
+ my @av;
+
+ $s = new ExtUtils::MakeMaker::charstar $s;
+
+ while (isSPACE($s)) { # leading whitespace is OK
+ $s++;
+ }
+
+ $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal,
+ \$width, \$alpha);
+
+ if ($errstr) {
+ # 'undef' is a special case and not an error
+ if ( $s ne 'undef') {
+ require Carp;
+ Carp::croak($errstr);
+ }
+ }
+
+ $start = $s;
+ if ($s eq 'v') {
+ $s++;
+ }
+ $pos = $s;
+
+ if ( $qv ) {
+ $$rv->{qv} = $qv;
+ }
+ if ( $alpha ) {
+ $$rv->{alpha} = $alpha;
+ }
+ if ( !$qv && $width < 3 ) {
+ $$rv->{width} = $width;
+ }
+
+ while (isDIGIT($pos)) {
+ $pos++;
+ }
+ if (!isALPHA($pos)) {
+ my $rev;
+
+ for (;;) {
+ $rev = 0;
+ {
+ # this is atoi() that delimits on underscores
+ my $end = $pos;
+ my $mult = 1;
+ my $orev;
+
+ # the following if() will only be true after the decimal
+ # point of a version originally created with a bare
+ # floating point number, i.e. not quoted in any way
+ #
+ if ( !$qv && $s > $start && $saw_decimal == 1 ) {
+ $mult *= 100;
+ while ( $s < $end ) {
+ $orev = $rev;
+ $rev += $s * $mult;
+ $mult /= 10;
+ if ( (abs($orev) > abs($rev))
+ || (abs($rev) > $VERSION_MAX )) {
+ warn("Integer overflow in version %d",
+ $VERSION_MAX);
+ $s = $end - 1;
+ $rev = $VERSION_MAX;
+ $vinf = 1;
+ }
+ $s++;
+ if ( $s eq '_' ) {
+ $s++;
+ }
+ }
+ }
+ else {
+ while (--$end >= $s) {
+ $orev = $rev;
+ $rev += $end * $mult;
+ $mult *= 10;
+ if ( (abs($orev) > abs($rev))
+ || (abs($rev) > $VERSION_MAX )) {
+ warn("Integer overflow in version");
+ $end = $s - 1;
+ $rev = $VERSION_MAX;
+ $vinf = 1;
+ }
+ }
+ }
+ }
+
+ # Append revision
+ push @av, $rev;
+ if ( $vinf ) {
+ $s = $last;
+ last;
+ }
+ elsif ( $pos eq '.' ) {
+ $s = ++$pos;
+ }
+ elsif ( $pos eq '_' && isDIGIT($pos+1) ) {
+ $s = ++$pos;
+ }
+ elsif ( $pos eq ',' && isDIGIT($pos+1) ) {
+ $s = ++$pos;
+ }
+ elsif ( isDIGIT($pos) ) {
+ $s = $pos;
+ }
+ else {
+ $s = $pos;
+ last;
+ }
+ if ( $qv ) {
+ while ( isDIGIT($pos) ) {
+ $pos++;
+ }
+ }
+ else {
+ my $digits = 0;
+ while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) {
+ if ( $pos ne '_' ) {
+ $digits++;
+ }
+ $pos++;
+ }
+ }
+ }
+ }
+ if ( $qv ) { # quoted versions always get at least three terms
+ my $len = $#av;
+ # This for loop appears to trigger a compiler bug on OS X, as it
+ # loops infinitely. Yes, len is negative. No, it makes no sense.
+ # Compiler in question is:
+ # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
+ # for ( len = 2 - len; len > 0; len-- )
+ # av_push(MUTABLE_AV(sv), newSViv(0));
+ #
+ $len = 2 - $len;
+ while ($len-- > 0) {
+ push @av, 0;
+ }
+ }
+
+ # need to save off the current version string for later
+ if ( $vinf ) {
+ $$rv->{original} = "v.Inf";
+ $$rv->{vinf} = 1;
+ }
+ elsif ( $s > $start ) {
+ $$rv->{original} = $start->currstr($s);
+ if ( $qv && $saw_decimal == 1 && $start ne 'v' ) {
+ # need to insert a v to be consistent
+ $$rv->{original} = 'v' . $$rv->{original};
+ }
+ }
+ else {
+ $$rv->{original} = '0';
+ push(@av, 0);
+ }
+
+ # And finally, store the AV in the hash
+ $$rv->{version} = \@av;
+
+ # fix RT#19517 - special case 'undef' as string
+ if ($s eq 'undef') {
+ $s += 5;
+ }
+
+ return $s;
+}
+
+sub new {
+ my $class = shift;
+ unless (defined $class or $#_ > 1) {
+ require Carp;
+ Carp::croak('Usage: version::new(class, version)');
+ }
+
+ my $self = bless ({}, ref ($class) || $class);
+ my $qv = FALSE;
+
+ if ( $#_ == 1 ) { # must be CVS-style
+ $qv = TRUE;
+ }
+ my $value = pop; # always going to be the last element
+
+ if ( ref($value) && eval('$value->isa("version")') ) {
+ # Can copy the elements directly
+ $self->{version} = [ @{$value->{version} } ];
+ $self->{qv} = 1 if $value->{qv};
+ $self->{alpha} = 1 if $value->{alpha};
+ $self->{original} = ''.$value->{original};
+ return $self;
+ }
+
+ if ( not defined $value or $value =~ /^undef$/ ) {
+ # RT #19517 - special case for undef comparison
+ # or someone forgot to pass a value
+ push @{$self->{version}}, 0;
+ $self->{original} = "0";
+ return ($self);
+ }
+
+
+ if (ref($value) =~ m/ARRAY|HASH/) {
+ require Carp;
+ Carp::croak("Invalid version format (non-numeric data)");
+ }
+
+ $value = _un_vstring($value);
+
+ if ($Config{d_setlocale} && eval { require POSIX } ) {
+ require locale;
+ my $currlocale = POSIX::setlocale(&POSIX::LC_ALL);
+
+ # if the current locale uses commas for decimal points, we
+ # just replace commas with decimal places, rather than changing
+ # locales
+ if ( POSIX::localeconv()->{decimal_point} eq ',' ) {
+ $value =~ tr/,/./;
+ }
+ }
+
+ # exponential notation
+ if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
+ $value = sprintf("%.9f",$value);
+ $value =~ s/(0+)$//; # trim trailing zeros
+ }
+
+ my $s = scan_version($value, \$self, $qv);
+
+ if ($s) { # must be something left over
+ warn("Version string '%s' contains invalid data; "
+ ."ignoring: '%s'", $value, $s);
+ }
+
+ return ($self);
+}
+
+*parse = \&new;
+
+sub numify {
+ my ($self) = @_;
+ unless (_verify($self)) {
+ require Carp;
+ Carp::croak("Invalid version object");
+ }
+ my $width = $self->{width} || 3;
+ my $alpha = $self->{alpha} || "";
+ my $len = $#{$self->{version}};
+ my $digit = $self->{version}[0];
+ my $string = sprintf("%d.", $digit );
+
+ for ( my $i = 1 ; $i < $len ; $i++ ) {
+ $digit = $self->{version}[$i];
+ if ( $width < 3 ) {
+ my $denom = 10**(3-$width);
+ my $quot = int($digit/$denom);
+ my $rem = $digit - ($quot * $denom);
+ $string .= sprintf("%0".$width."d_%d", $quot, $rem);
+ }
+ else {
+ $string .= sprintf("%03d", $digit);
+ }
+ }
+
+ if ( $len > 0 ) {
+ $digit = $self->{version}[$len];
+ if ( $alpha && $width == 3 ) {
+ $string .= "_";
+ }
+ $string .= sprintf("%0".$width."d", $digit);
+ }
+ else # $len = 0
+ {
+ $string .= sprintf("000");
+ }
+
+ return $string;
+}
+
+sub normal {
+ my ($self) = @_;
+ unless (_verify($self)) {
+ require Carp;
+ Carp::croak("Invalid version object");
+ }
+ my $alpha = $self->{alpha} || "";
+ my $len = $#{$self->{version}};
+ my $digit = $self->{version}[0];
+ my $string = sprintf("v%d", $digit );
+
+ for ( my $i = 1 ; $i < $len ; $i++ ) {
+ $digit = $self->{version}[$i];
+ $string .= sprintf(".%d", $digit);
+ }
+
+ if ( $len > 0 ) {
+ $digit = $self->{version}[$len];
+ if ( $alpha ) {
+ $string .= sprintf("_%0d", $digit);
+ }
+ else {
+ $string .= sprintf(".%0d", $digit);
+ }
+ }
+
+ if ( $len <= 2 ) {
+ for ( $len = 2 - $len; $len != 0; $len-- ) {
+ $string .= sprintf(".%0d", 0);
+ }
+ }
+
+ return $string;
+}
+
+sub stringify {
+ my ($self) = @_;
+ unless (_verify($self)) {
+ require Carp;
+ Carp::croak("Invalid version object");
+ }
+ return exists $self->{original}
+ ? $self->{original}
+ : exists $self->{qv}
+ ? $self->normal
+ : $self->numify;
+}
+
+sub vcmp {
+ require UNIVERSAL;
+ my ($left,$right,$swap) = @_;
+ my $class = ref($left);
+ unless ( UNIVERSAL::isa($right, $class) ) {
+ $right = $class->new($right);
+ }
+
+ if ( $swap ) {
+ ($left, $right) = ($right, $left);
+ }
+ unless (_verify($left)) {
+ require Carp;
+ Carp::croak("Invalid version object");
+ }
+ unless (_verify($right)) {
+ require Carp;
+ Carp::croak("Invalid version format");
+ }
+ my $l = $#{$left->{version}};
+ my $r = $#{$right->{version}};
+ my $m = $l < $r ? $l : $r;
+ my $lalpha = $left->is_alpha;
+ my $ralpha = $right->is_alpha;
+ my $retval = 0;
+ my $i = 0;
+ while ( $i <= $m && $retval == 0 ) {
+ $retval = $left->{version}[$i] <=> $right->{version}[$i];
+ $i++;
+ }
+
+ # tiebreaker for alpha with identical terms
+ if ( $retval == 0
+ && $l == $r
+ && $left->{version}[$m] == $right->{version}[$m]
+ && ( $lalpha || $ralpha ) ) {
+
+ if ( $lalpha && !$ralpha ) {
+ $retval = -1;
+ }
+ elsif ( $ralpha && !$lalpha) {
+ $retval = +1;
+ }
+ }
+
+ # possible match except for trailing 0's
+ if ( $retval == 0 && $l != $r ) {
+ if ( $l < $r ) {
+ while ( $i <= $r && $retval == 0 ) {
+ if ( $right->{version}[$i] != 0 ) {
+ $retval = -1; # not a match after all
+ }
+ $i++;
+ }
+ }
+ else {
+ while ( $i <= $l && $retval == 0 ) {
+ if ( $left->{version}[$i] != 0 ) {
+ $retval = +1; # not a match after all
+ }
+ $i++;
+ }
+ }
+ }
+
+ return $retval;
+}
+
+sub vbool {
+ my ($self) = @_;
+ return vcmp($self,$self->new("0"),1);
+}
+
+sub vnoop {
+ require Carp;
+ Carp::croak("operation not supported with version object");
+}
+
+sub is_alpha {
+ my ($self) = @_;
+ return (exists $self->{alpha});
+}
+
+sub qv {
+ my $value = shift;
+ my $class = $CLASS;
+ if (@_) {
+ $class = ref($value) || $value;
+ $value = shift;
+ }
+
+ $value = _un_vstring($value);
+ $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
+ my $obj = $CLASS->new($value);
+ return bless $obj, $class;
+}
+
+*declare = \&qv;
+
+sub is_qv {
+ my ($self) = @_;
+ return (exists $self->{qv});
+}
+
+
+sub _verify {
+ my ($self) = @_;
+ if ( ref($self)
+ && eval { exists $self->{version} }
+ && ref($self->{version}) eq 'ARRAY'
+ ) {
+ return 1;
+ }
+ else {
+ return 0;
+ }
+}
+
+sub _is_non_alphanumeric {
+ my $s = shift;
+ $s = new ExtUtils::MakeMaker::charstar $s;
+ while ($s) {
+ return 0 if isSPACE($s); # early out
+ return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/);
+ $s++;
+ }
+ return 0;
+}
+
+sub _un_vstring {
+ my $value = shift;
+ # may be a v-string
+ if ( length($value) >= 3 && $value !~ /[._]/
+ && _is_non_alphanumeric($value)) {
+ my $tvalue;
+ if ( $] ge 5.008_001 ) {
+ $tvalue = _find_magic_vstring($value);
+ $value = $tvalue if length $tvalue;
+ }
+ elsif ( $] ge 5.006_000 ) {
+ $tvalue = sprintf("v%vd",$value);
+ if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) {
+ # must be a v-string
+ $value = $tvalue;
+ }
+ }
+ }
+ return $value;
+}
+
+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 {
+ my ($obj, $req) = @_;
+ my $class = ref($obj) || $obj;
+
+ no strict 'refs';
+ if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
+ # file but no package
+ require Carp;
+ Carp::croak( "$class defines neither package nor VERSION"
+ ."--version check failed");
+ }
+
+ my $version = eval "\$$class\::VERSION";
+ if ( defined $version ) {
+ local $^W if $] <= 5.008;
+ $version = ExtUtils::MakeMaker::version::vpp->new($version);
+ }
+
+ if ( defined $req ) {
+ unless ( defined $version ) {
+ require Carp;
+ my $msg = $] < 5.006
+ ? "$class version $req required--this is only version "
+ : "$class does not define \$$class\::VERSION"
+ ."--version check failed";
+
+ if ( $ENV{VERSION_DEBUG} ) {
+ Carp::confess($msg);
+ }
+ else {
+ Carp::croak($msg);
+ }
+ }
+
+ $req = ExtUtils::MakeMaker::version::vpp->new($req);
+
+ if ( $req > $version ) {
+ require Carp;
+ if ( $req->is_qv ) {
+ Carp::croak(
+ sprintf ("%s version %s required--".
+ "this is only version %s", $class,
+ $req->normal, $version->normal)
+ );
+ }
+ else {
+ Carp::croak(
+ sprintf ("%s version %s required--".
+ "this is only version %s", $class,
+ $req->stringify, $version->stringify)
+ );
+ }
+ }
+ }
+
+ return defined $version ? $version->stringify : undef;
+}
+
+1; #this line is important and will help the module return a true value
# There's just too much Dynaloader incest here to turn on strict vars.
use strict 'refs';
-our $VERSION = '6.98';
+our $VERSION = '7.02';
require Exporter;
our @ISA = ('Exporter');
our @ISA = qw(Exporter);
our @EXPORT = qw(&Mksymlists);
-our $VERSION = '6.98';
+our $VERSION = '7.02';
sub Mksymlists {
my(%spec) = @_;
print $def "EXPORTS\n ";
my @syms;
# Export public symbols both with and without underscores to
- # ensure compatibility between DLLs from different compilers
+ # ensure compatibility between DLLs from Borland C and Visual C
# NOTE: DynaLoader itself only uses the names without underscores,
# so this is only to cover the case when the extension DLL may be
# linked to directly from C. GSAR 97-07-10
- if ($Config::Config{'cc'} =~ /^bcc/i) {
- for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) {
- push @syms, "_$_", "$_ = _$_";
+
+ #bcc dropped in 5.16, so dont create useless extra symbols for export table
+ unless($] >= 5.016) {
+ if ($Config::Config{'cc'} =~ /^bcc/i) {
+ push @syms, "_$_", "$_ = _$_"
+ for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}});
}
- }
- else {
- for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) {
- push @syms, "$_", "_$_ = $_";
+ else {
+ push @syms, "$_", "_$_ = $_"
+ for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}});
}
+ } else {
+ push @syms, "$_"
+ for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}});
}
print $def join("\n ",@syms, "\n") if @syms;
_print_imports($def, $data);
use strict;
use warnings;
-our $VERSION = '6.98';
+our $VERSION = '7.02';
use Cwd;
use File::Spec;
ok( setup_recurs(), 'setup' );
END {
- ok( chdir File::Spec->updir );
+ ok( chdir File::Spec->updir, 'chdir updir' );
ok( teardown_recurs(), 'teardown' );
}
#!/usr/bin/perl -w
-# Tests INSTALL_BASE
+# Tests INSTALL_BASE to a directory without AND with a space in the name
BEGIN {
unshift @INC, 't/lib';
use strict;
use File::Path;
use Config;
+my @INSTDIRS = ('../dummy-install', '../dummy install');
+my $CLEANUP = 1;
+$CLEANUP &&= 1; # so always 1 or numerically 0
-use Test::More
- $ENV{PERL_CORE} && $Config{'usecrosscompile'}
- ? (skip_all => "no toolchain installed when cross-compiling")
- : (tests => 20);
use MakeMaker::Test::Utils;
use MakeMaker::Test::Setup::BFD;
+use Test::More;
+use Config;
+use ExtUtils::MM;
+plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+ ? (skip_all => "cross-compiling and make not available")
+ : (tests => 3 + $CLEANUP + @INSTDIRS * (15 + $CLEANUP));
my $Is_VMS = $^O eq 'VMS';
my $perl = which_perl();
use File::Temp qw[tempdir];
-my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
+my $tmpdir = tempdir( DIR => 't', CLEANUP => $CLEANUP );
chdir $tmpdir;
perl_lib;
ok( setup_recurs(), 'setup' );
END {
- ok( chdir File::Spec->updir );
- ok( teardown_recurs(), 'teardown' );
+ ok( chdir File::Spec->updir, 'chdir updir' );
+ ok( teardown_recurs(), 'teardown' ) if $CLEANUP;
+ map { rmtree $_ } @INSTDIRS if $CLEANUP;
}
ok( chdir('Big-Dummy'), "chdir'd to Big-Dummy") || diag("chdir failed; $!");
-my @mpl_out = run(qq{$perl Makefile.PL "INSTALL_BASE=../dummy-install"});
-END { rmtree '../dummy-install'; }
+for my $instdir (@INSTDIRS) {
+ my @mpl_out = run(qq{$perl Makefile.PL "INSTALL_BASE=$instdir"});
-cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) ||
- diag(@mpl_out);
+ cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) ||
+ diag(@mpl_out);
-my $makefile = makefile_name();
-ok( grep(/^Writing $makefile for Big::Dummy/,
- @mpl_out) == 1,
- 'Makefile.PL output looks right');
+ my $makefile = makefile_name();
+ ok( grep(/^Writing $makefile for Big::Dummy/,
+ @mpl_out) == 1,
+ 'Makefile.PL output looks right');
-my $make = make_run();
-run("$make"); # this is necessary due to a dmake bug.
-my $install_out = run("$make install");
-is( $?, 0, ' make install exited normally' ) || diag $install_out;
-like( $install_out, qr/^Installing /m );
+ my $make = make_run();
+ run("$make"); # this is necessary due to a dmake bug.
+ my $install_out = run("$make install");
+ is( $?, 0, ' make install exited normally' ) || diag $install_out;
+ like( $install_out, qr/^Installing /m, '"Installing" in output' );
-ok( -r '../dummy-install', ' install dir created' );
+ ok( -r $instdir, ' install dir created' );
-my @installed_files =
- ('../dummy-install/lib/perl5/Big/Dummy.pm',
- '../dummy-install/lib/perl5/Big/Liar.pm',
- '../dummy-install/bin/program',
- "../dummy-install/lib/perl5/$Config{archname}/perllocal.pod",
- "../dummy-install/lib/perl5/$Config{archname}/auto/Big/Dummy/.packlist"
- );
+ my @installed_files =
+ ("$instdir/lib/perl5/Big/Dummy.pm",
+ "$instdir/lib/perl5/Big/Liar.pm",
+ "$instdir/bin/program",
+ "$instdir/lib/perl5/$Config{archname}/perllocal.pod",
+ "$instdir/lib/perl5/$Config{archname}/auto/Big/Dummy/.packlist"
+ );
-foreach my $file (@installed_files) {
- ok( -e $file, " $file installed" );
- ok( -r $file, " $file readable" );
-}
+ foreach my $file (@installed_files) {
+ ok( -e $file, " $file installed" );
+ ok( -r $file, " $file readable" );
+ }
-# nmake outputs its damned logo
-# Send STDERR off to oblivion.
-open(SAVERR, ">&STDERR") or die $!;
-open(STDERR, ">".File::Spec->devnull) or die $!;
+ # nmake outputs its damned logo
+ # Send STDERR off to oblivion.
+ open(SAVERR, ">&STDERR") or die $!;
+ open(STDERR, ">".File::Spec->devnull) or die $!;
-my $realclean_out = run("$make realclean");
-is( $?, 0, 'realclean' ) || diag($realclean_out);
+ if ($CLEANUP) {
+ my $realclean_out = run("$make realclean");
+ is( $?, 0, 'realclean' ) || diag($realclean_out);
+ }
-open(STDERR, ">&SAVERR") or die $!;
-close SAVERR;
+ open(STDERR, ">&SAVERR") or die $!;
+ close SAVERR;
+}
$t->cflags();
# Brief bug where CCFLAGS was being blown away
- is( $t->{CCFLAGS}, '-DMY_THING', 'cflags retains CCFLAGS' );
+ like( $t->{CCFLAGS}, qr/\-DMY_THING/, 'cflags retains CCFLAGS' );
}
my $mm = bless {}, "MM";
-sub extract_params {
- my $text = join "\n", @_;
-
- $text =~ s{^\s* \# \s+ MakeMaker\ Parameters: \s*\n}{}x;
- $text =~ s{^#}{}gms;
- $text =~ s{\n}{,\n}g;
-
- no strict 'subs';
- return { eval "$text" };
+sub process_cmp {
+ my ($args, $expected, $label) = @_;
+ my $got = join '',
+ map "$_\n", $mm->_MakeMaker_Parameters_section($args || ());
+ $got =~ s/^#\s*MakeMaker Parameters:\n+//;
+ is $got, $expected, $label;
}
-sub test_round_trip {
- my $args = shift;
- my $want = @_ ? shift : $args;
-
- my $have = extract_params($mm->_MakeMaker_Parameters_section($args));
-
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- is_deeply $have, $want or diag explain $have, "\n", $want;
-}
-
-is join("", $mm->_MakeMaker_Parameters_section()), <<'EXPECT', "nothing";
-# MakeMaker Parameters:
+process_cmp undef, '', 'nothing';
+process_cmp { NAME => "Foo" }, <<'EXPECT', "name only";
+# NAME => q[Foo]
+EXPECT
+process_cmp
+ { NAME => "Foo", PREREQ_PM => { "Foo::Bar" => 0 } }, <<'EXPECT', "PREREQ v0";
+# NAME => q[Foo]
+# PREREQ_PM => { Foo::Bar=>q[0] }
+EXPECT
+process_cmp
+ { NAME => "Foo", PREREQ_PM => { "Foo::Bar" => 1.23 } },
+ <<'EXPECT', "PREREQ v-non-0";
+# NAME => q[Foo]
+# PREREQ_PM => { Foo::Bar=>q[1.23] }
EXPECT
-test_round_trip({ NAME => "Foo" });
-test_round_trip({ NAME => "Foo", PREREQ_PM => { "Foo::Bar" => 0 } });
-test_round_trip({ NAME => "Foo", PREREQ_PM => { "Foo::Bar" => 1.23 } });
-
-# Test the special case for BUILD_REQUIRES
-{
- my $have = {
- NAME => "Foo",
- PREREQ_PM => { "Foo::Bar" => 1.23 },
- BUILD_REQUIRES => { "Baz" => 0.12 },
- };
-
- my $want = {
- NAME => "Foo",
- PREREQ_PM => {
- "Foo::Bar" => 1.23,
- "Baz" => 0.12,
- },
- BUILD_REQUIRES => { "Baz" => 0.12 },
- };
+process_cmp
+ {
+ NAME => "Foo",
+ PREREQ_PM => { "Foo::Bar" => 1.23 },
+ BUILD_REQUIRES => { "Baz" => 0.12 },
+ },
+ <<'EXPECT', "BUILD_REQUIRES";
+# BUILD_REQUIRES => { Baz=>q[0.12] }
+# NAME => q[Foo]
+# PREREQ_PM => { Baz=>q[0.12], Foo::Bar=>q[1.23] }
+EXPECT
- test_round_trip( $have, $want );
-}
+process_cmp
+ {
+ NAME => "Foo",
+ PREREQ_PM => { "Foo::Bar" => 1.23, Long => 1.45, Short => 0 },
+ BUILD_REQUIRES => { "Baz" => 0.12 },
+ },
+ <<'EXPECT', "ensure sorting";
+# BUILD_REQUIRES => { Baz=>q[0.12] }
+# NAME => q[Foo]
+# PREREQ_PM => { Baz=>q[0.12], Foo::Bar=>q[1.23], Long=>q[1.45], Short=>q[0] }
+EXPECT
done_testing();
-
}
use strict;
-use Config;
-use Test::More
- $ENV{PERL_CORE} && $Config{'usecrosscompile'}
- ? (skip_all => "no toolchain installed when cross-compiling")
- : (tests => 9);
use File::Spec;
use File::Temp qw[tempdir];
use MakeMaker::Test::Setup::PL_FILES;
use MakeMaker::Test::Utils;
+use Config;
+use Test::More;
+use ExtUtils::MM;
+plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+ ? (skip_all => "cross-compiling and make not available")
+ : (tests => 9);
my $perl = which_perl();
my $make = make_run();
# This test puts MakeMaker through the paces of a basic perl module
# build, test and installation of the Big::Fat::Dummy module.
+# Module::Install relies on being able to patch the generated Makefile
+# to add flags to $(PERL)
+# This test includes adding ' -Iinc' to $(PERL), and checking 'make install'
+# after that works. Done here as back-compat is considered basic.
+
BEGIN {
unshift @INC, 't/lib';
}
use strict;
use Config;
use ExtUtils::MakeMaker;
+use utf8;
-use Test::More
- $ENV{PERL_CORE} && $Config{'usecrosscompile'}
- ? (skip_all => "no toolchain installed when cross-compiling")
- : (tests => 171);
use MakeMaker::Test::Utils;
use MakeMaker::Test::Setup::BFD;
+use Config;
+use Test::More;
+use ExtUtils::MM;
+plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+ ? (skip_all => "cross-compiling and make not available")
+ : (tests => 171);
use File::Find;
use File::Spec;
use File::Path;
my $perl = which_perl();
my $Is_VMS = $^O eq 'VMS';
+my $OLD_CP; # crude but...
+if ($^O eq "MSWin32") {
+ $OLD_CP = $1 if qx(chcp) =~ /(\d+)$/ and $? == 0;
+ qx(chcp 1252) if defined $OLD_CP;
+}
+END { qx(chcp $OLD_CP) if $^O eq "MSWin32" and defined $OLD_CP }
my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
chdir $tmpdir;
ok( chdir('Big-Dummy'), "chdir'd to Big-Dummy" ) ||
diag("chdir failed: $!");
-my @mpl_out = run(qq{$perl Makefile.PL "PREFIX=../dummy-install"});
-END { rmtree '../dummy-install'; }
+sub extrachar { $] > 5.008 && !$ENV{PERL_CORE} ? utf8::decode(my $c='š') : 's' }
+my $DUMMYINST = '../dummy-in'.extrachar().'tall';
+my @mpl_out = run(qq{$perl Makefile.PL "PREFIX=$DUMMYINST"});
+END { rmtree $DUMMYINST; }
cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) ||
diag(@mpl_out);
# -M is flakey on VMS
my $mtime = (stat($makefile))[9];
-cmp_ok( $Touch_Time, '<=', $mtime, ' its been touched' );
+cmp_ok( $Touch_Time, '<=', $mtime, ' been touched' );
END { unlink makefile_name(), makefile_backup() }
my $make = make_run();
{
- # Supress 'make manifest' noise
+ # Suppress 'make manifest' noise
local $ENV{PERL_MM_MANIFEST_VERBOSE} = 0;
my $manifest_out = run("$make manifest");
ok( -e 'MANIFEST', 'make manifest created a MANIFEST' );
- ok( -s 'MANIFEST', ' its not empty' );
+ ok( -s 'MANIFEST', ' not empty' );
}
END { unlink 'MANIFEST'; }
is( $?, 0, ' exited normally' ) ||
diag $test_out;
+# now simulate what Module::Install does, and edit $(PERL) to add flags
+open my $fh, '<', $makefile;
+my $mtext = join '', <$fh>;
+close $fh;
+$mtext =~ s/^(\s*PERL\s*=.*)$/$1 -Iinc/m;
+open $fh, '>', $makefile;
+print $fh $mtext;
+close $fh;
my $install_out = run("$make install");
is( $?, 0, 'install' ) || diag $install_out;
like( $install_out, qr/^Installing /m );
-ok( -r '../dummy-install', ' install dir created' );
-my %files = ();
-find( sub {
- # do it case-insensitive for non-case preserving OSs
- my $file = lc $_;
-
- # VMS likes to put dots on the end of things that don't have them.
- $file =~ s/\.$// if $Is_VMS;
-
- $files{$file} = $File::Find::name;
-}, '../dummy-install' );
-ok( $files{'dummy.pm'}, ' Dummy.pm installed' );
-ok( $files{'liar.pm'}, ' Liar.pm installed' );
-ok( $files{'program'}, ' program installed' );
-ok( $files{'.packlist'}, ' packlist created' );
-ok( $files{'perllocal.pod'},' perllocal.pod created' );
+sub check_dummy_inst {
+ my $loc = shift;
+ my %files = ();
+ find( sub {
+ # do it case-insensitive for non-case preserving OSs
+ my $file = lc $_;
+ # VMS likes to put dots on the end of things that don't have them.
+ $file =~ s/\.$// if $Is_VMS;
+ $files{$file} = $File::Find::name;
+ }, $loc );
+ ok( $files{'dummy.pm'}, ' Dummy.pm installed' );
+ ok( $files{'liar.pm'}, ' Liar.pm installed' );
+ ok( $files{'program'}, ' program installed' );
+ ok( $files{'.packlist'}, ' packlist created' );
+ ok( $files{'perllocal.pod'},' perllocal.pod created' );
+ \%files;
+}
+SKIP: {
+ ok( -r $DUMMYINST, ' install dir created' )
+ or skip "$DUMMYINST doesn't exist", 5;
+ check_dummy_inst($DUMMYINST);
+}
SKIP: {
skip 'VMS install targets do not preserve $(PREFIX)', 8 if $Is_VMS;
like( $install_out, qr/^Installing /m );
ok( -r 'elsewhere', ' install dir created' );
- %files = ();
- find( sub { $files{$_} = $File::Find::name; }, 'elsewhere' );
- ok( $files{'Dummy.pm'}, ' Dummy.pm installed' );
- ok( $files{'Liar.pm'}, ' Liar.pm installed' );
- ok( $files{'program'}, ' program installed' );
- ok( $files{'.packlist'}, ' packlist created' );
- ok( $files{'perllocal.pod'},' perllocal.pod created' );
+ check_dummy_inst('elsewhere');
rmtree('elsewhere');
}
like( $install_out, qr/^Installing /m );
ok( -d 'other', ' destdir created' );
- %files = ();
- my $perllocal;
- find( sub {
- $files{$_} = $File::Find::name;
- }, 'other' );
- ok( $files{'Dummy.pm'}, ' Dummy.pm installed' );
- ok( $files{'Liar.pm'}, ' Liar.pm installed' );
- ok( $files{'program'}, ' program installed' );
- ok( $files{'.packlist'}, ' packlist created' );
- ok( $files{'perllocal.pod'},' perllocal.pod created' );
+ my $files = check_dummy_inst('other');
- ok( open(PERLLOCAL, $files{'perllocal.pod'} ) ) ||
- diag("Can't open $files{'perllocal.pod'}: $!");
+ ok( open(PERLLOCAL, $files->{'perllocal.pod'} ) ) ||
+ diag("Can't open $files->{'perllocal.pod'}: $!");
{ local $/;
unlike(<PERLLOCAL>, qr/other/, 'DESTDIR should not appear in perllocal');
}
ok( !-d 'elsewhere', ' install dir not created' );
ok( -d 'other/elsewhere', ' destdir created' );
- %files = ();
- find( sub { $files{$_} = $File::Find::name; }, 'other/elsewhere' );
- ok( $files{'Dummy.pm'}, ' Dummy.pm installed' );
- ok( $files{'Liar.pm'}, ' Liar.pm installed' );
- ok( $files{'program'}, ' program installed' );
- ok( $files{'.packlist'}, ' packlist created' );
- ok( $files{'perllocal.pod'},' perllocal.pod created' );
+ check_dummy_inst('other/elsewhere');
rmtree('other');
}
# Make sure init_dirscan doesn't go into the distdir
-@mpl_out = run(qq{$perl Makefile.PL "PREFIX=../dummy-install"});
+@mpl_out = run(qq{$perl Makefile.PL "PREFIX=$DUMMYINST"});
cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) || diag(@mpl_out);
open(STDERR, ">&SAVERR") or die $!;
close SAVERR;
-
sub _normalize {
my $hash = shift;
qq{cd $dir
command1
command2
- cd $expected_updir};
+ cd $expected_updir}, 'nmake';
}
{
::is $mm->cd(@cd_args),
qq{cd $dir && command1
- cd $dir && command2};
+ cd $dir && command2}, 'dmake';
}
}
{
is +ExtUtils::MM_Unix->cd(@cd_args),
qq{cd $dir && command1
- cd $dir && command2};
+ cd $dir && command2}, 'Unix';
}
SKIP: {
Set Default [.some.dir]
command1
command2
- Set Default 'startdir'};
+ Set Default 'startdir'}, 'VMS';
}
use Cwd 'abs_path';
use Test::More;
-
-plan skip_all => "no toolchain installed when cross-compiling"
- if $ENV{PERL_CORE} && $Config{'usecrosscompile'};
+use ExtUtils::MM;
+plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+ ? (skip_all => "cross-compiling and make not available")
+ : ();
#--------------------- Setup
--- /dev/null
+package MakeMaker::Test::Setup::Unicode;
+
+@ISA = qw(Exporter);
+require Exporter;
+@EXPORT = qw(setup_recurs teardown_recurs);
+
+use strict;
+use File::Path;
+use File::Basename;
+use MakeMaker::Test::Utils;
+use utf8;
+use Config;
+
+my %Files = (
+ 'Problem-Module/Makefile.PL' => <<'PL_END',
+use ExtUtils::MakeMaker;
+use utf8;
+
+WriteMakefile(
+ NAME => 'Problem::Module',
+ ABSTRACT_FROM => 'lib/Problem/Module.pm',
+ AUTHOR => q{Danijel Tašov},
+ EXE_FILES => [ qw(bin/probscript) ],
+ INSTALLMAN1DIR => "some", # even if disabled in $Config{man1dir}
+ MAN1EXT => 1, # set to 0 if man pages disabled
+);
+PL_END
+
+ 'Problem-Module/lib/Problem/Module.pm' => <<'pm_END',
+use utf8;
+
+=pod
+
+=encoding utf8
+
+=head1 NAME
+
+Problem::Module - Danijel Tašov's great new module
+
+=cut
+
+1;
+pm_END
+
+ 'Problem-Module/bin/probscript' => <<'pl_END',
+#!/usr/bin/perl
+use utf8;
+
+=encoding utf8
+
+=head1 NAME
+
+文档 - Problem script
+pl_END
+);
+
+
+sub setup_recurs {
+ while(my($file, $text) = each %Files) {
+ # Convert to a relative, native file path.
+ $file = File::Spec->catfile(File::Spec->curdir, split m{\/}, $file);
+
+ my $dir = dirname($file);
+ mkpath $dir;
+ my $utf8 = ($] < 5.008 or !$Config{useperlio}) ? "" : ":utf8";
+ open(FILE, ">$utf8", $file) || die "Can't create $file: $!";
+ print FILE $text;
+ close FILE;
+
+ # ensure file at least 1 second old for makes that assume
+ # files with the same time are out of date.
+ my $time = calibrate_mtime();
+ utime $time, $time - 1, $file;
+ }
+
+ return 1;
+}
+
+sub teardown_recurs {
+ foreach my $file (keys %Files) {
+ my $dir = dirname($file);
+ if( -e $dir ) {
+ rmtree($dir) || return;
+ }
+ }
+ return 1;
+}
+
+
+1;
use File::Path;
use File::Basename;
use MakeMaker::Test::Utils;
+use Config;
-my $Is_VMS = $^O eq 'VMS';
+use ExtUtils::MM;
+my $typemap = 'type map';
+$typemap =~ s/ //g unless MM->new({NAME=>'name'})->can_dep_space;
my %Files = (
'XS-Test/lib/XS/Test.pm' => <<'END',
1;
END
- 'XS-Test/Makefile.PL' => <<'END',
+ 'XS-Test/Makefile.PL' => <<END,
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'XS::Test',
VERSION_FROM => 'lib/XS/Test.pm',
+ TYPEMAPS => [ '$typemap' ],
+ PERL => "\$^X -w",
);
END
+ "XS-Test/$typemap" => '',
+
'XS-Test/Test.xs' => <<'END',
#include "EXTERN.h"
#include "perl.h"
HARNESS_VERBOSE
PREFIX
MAKEFLAGS
+ PERL_INSTALL_QUIET
);
my %default_env_keys;
=head1 DESCRIPTION
-A consolidation of little utility functions used through out the
+A consolidation of little utility functions used throughout the
MakeMaker test suite.
=head2 Functions
last if -x $perlpath;
}
}
+ $perlpath = qq{"$perlpath"}; # "safe... in a command line" even with spaces
return $perlpath;
}
my $make = $Config{make};
$make = $ENV{MAKE} if exists $ENV{MAKE};
- return $make;
+ return $Is_VMS ? $make : qq{"$make"};
}
=item B<make_run>
# Unix, modern Windows and OS/2 from 5.005_54 up can handle 2>&1
# This makes our failure diagnostics nicer to read.
- if( MM->os_flavor_is('Unix') or
- (MM->os_flavor_is('Win32') and !MM->os_flavor_is('Win9x')) or
- ($] > 5.00554 and MM->os_flavor_is('OS/2'))
- ) {
+ if (MM->can_redirect_error) {
return `$cmd 2>&1`;
}
else {
META_ADD => {
provides => {
"CPAN::Testers::ParseReport" => {
- version => version->declare("v1.2.3"),
+ version => version->new("v1.2.3"),
file => "lib/CPAN/Testers/ParseReport.pm"
}
}
}
use strict;
-use Config;
-use Test::More
- $ENV{PERL_CORE} && $Config{'usecrosscompile'}
- ? (skip_all => "no toolchain installed when cross-compiling")
- : (tests => 36);
use TieOut;
use MakeMaker::Test::Utils;
use MakeMaker::Test::Setup::MPV;
+use Config;
+use Test::More;
+use ExtUtils::MM;
+plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+ ? (skip_all => "cross-compiling and make not available")
+ : (tests => 36);
use File::Path;
use ExtUtils::MakeMaker;
use strict;
use lib 't/lib';
-use Config;
use Test::More;
+use Config;
# In a BEGIN block so the END tests aren't registered.
BEGIN {
- plan skip_all => "miniperl test only necessary for the perl core"
+ plan skip_all => 'miniperl test only necessary for the perl core'
if !$ENV{PERL_CORE};
- plan skip_all => "no toolchain installed when cross-compiling"
- if $ENV{PERL_CORE} && $Config{'usecrosscompile'};
-
- plan "no_plan";
-}
-
-BEGIN {
- ok !$INC{"ExtUtils/MakeMaker.pm"}, "MakeMaker is not yet loaded";
+ plan $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+ ? (skip_all => 'cross-compiling and make not available')
+ : 'no_plan';
}
# Disable all XS from here on
use MakeMaker::Test::Utils;
use MakeMaker::Test::Setup::BFD;
-
my $perl = which_perl();
my $makefile = makefile_name();
my $make = make_run();
use File::Spec;
my $TB = Test::More->builder;
+my $perl = which_perl;
BEGIN { use_ok('ExtUtils::MM') }
sub try_oneliner {
my($code, $switches, $expect, $name) = @_;
my $cmd = $mm->oneliner($code, $switches);
- $cmd =~ s{\$\(ABSPERLRUN\)}{$^X};
+ $cmd =~ s{\$\(ABSPERLRUN\)}{$perl};
# VMS likes to put newlines at the end of commands if there isn't
# one already.
q[our $VERSION = '1.23';] => '1.23',
q[$CGI::VERSION='3.63'] => '3.63',
q[$VERSION = "1.627"; # ==> ALSO update the version in the pod text below!] => '1.627',
+ q[BEGIN { our $VERSION = '1.23' }] => '1.23',
'$Something::VERSION == 1.0' => undef,
'$Something::VERSION <= 1.0' => undef,
use strict;
use lib 't/lib';
-use Config;
-use Test::More
- $ENV{PERL_CORE} && $Config{'usecrosscompile'}
- ? (skip_all => "no toolchain installed when cross-compiling")
- : 'no_plan';
use File::Temp qw[tempdir];
use ExtUtils::MakeMaker;
use MakeMaker::Test::Utils;
use MakeMaker::Test::Setup::BFD;
-
+use Config;
+use Test::More;
+use ExtUtils::MM;
+plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+ ? (skip_all => "cross-compiling and make not available")
+ : 'no_plan';
my $perl = which_perl();
my $makefile = makefile_name();
run_ok(qq{$perl Makefile.PL});
# XXX This is a fragile way to check that it reran.
- like run_ok($make), qr/^Skip /ms;
+ TODO: {
+ local $TODO = 'This one is fragile on some systems for some reason that needs investigation';
+ like run_ok($make), qr/^Skip /ms;
+ }
ok( -e "blib/lib/Big/Dummy.pm", "blib copied pm file" );
}
}
use strict;
+use Config;
use Test::More tests => 8;
use MakeMaker::Test::Utils;
use MakeMaker::Test::Setup::BFD;
{
my $warnings = '';
local $SIG{__WARN__} = sub {
+ if ( $Config{usecrosscompile} ) {
+ # libraries might not be present on the target system
+ # when cross-compiling
+ return if $_[0] =~ /\A\QWarning (mostly harmless): No library found for \E.+/
+ }
$warnings = join '', @_;
};
}
use strict;
+use Config;
use Test::More tests => 16;
use File::Temp qw[tempdir];
ok( my $stdout = tie *STDOUT, 'TieOut' );
my $warnings = '';
local $SIG{__WARN__} = sub {
+ if ( $Config{usecrosscompile} ) {
+ # libraries might not be present on the target system
+ # when cross-compiling
+ return if $_[0] =~ /\A\QWarning (mostly harmless): No library found for \E.+/
+ }
$warnings .= join '', @_;
};
# prerequisite warnings are disabled while building the perl core:
use strict;
use Config;
-use Test::More
- $ENV{PERL_CORE} && $Config{'usecrosscompile'}
- ? (skip_all => "no toolchain installed when cross-compiling")
- : (tests => 26);
use File::Temp qw[tempdir];
use MakeMaker::Test::Utils;
use MakeMaker::Test::Setup::Recurs;
+use Config;
+use Test::More;
+use ExtUtils::MM;
+plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+ ? (skip_all => "cross-compiling and make not available")
+ : (tests => 26);
# 'make disttest' sets a bunch of environment variables which interfere
# with our testing.
}
use strict;
-use Config;
-use Test::More
- $ENV{PERL_CORE} && $Config{'usecrosscompile'}
- ? (skip_all => "no toolchain installed when cross-compiling")
- : (tests => 20);
use TieOut;
use MakeMaker::Test::Utils;
use MakeMaker::Test::Setup::SAS;
+use Config;
+use Test::More;
+use ExtUtils::MM;
+plan !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}
+ ? (skip_all => "cross-compiling and make not available")
+ : (tests => 20);
use File::Path;
+use File::Temp qw[tempdir];
use ExtUtils::MakeMaker;
my $make = make_run();
my $makefile = makefile_name();
-chdir 't';
+my $tmpdir = tempdir( DIR => 't', CLEANUP => 1 );
+chdir $tmpdir;
perl_lib();
--- /dev/null
+# Test problems in Makefile.PL's and hint files.
+
+BEGIN {
+ unshift @INC, 't/lib';
+}
+chdir 't';
+
+use strict;
+use Test::More;
+use Config;
+BEGIN {
+ plan skip_all => 'Need perlio and perl 5.8+.'
+ if $] < 5.008 or !$Config{useperlio};
+ plan tests => 9;
+}
+use ExtUtils::MM;
+use MakeMaker::Test::Setup::Unicode;
+use MakeMaker::Test::Utils qw(makefile_name make_run run);
+use TieOut;
+
+my $MM = bless { DIR => ['.'] }, 'MM';
+
+ok( setup_recurs(), 'setup' );
+END {
+ ok( chdir File::Spec->updir, 'chdir updir' );
+ ok( teardown_recurs(), 'teardown' );
+}
+
+ok( chdir 'Problem-Module', "chdir'd to Problem-Module" ) ||
+ diag("chdir failed: $!");
+
+if ($] >= 5.008) {
+ eval { require ExtUtils::MakeMaker::Locale; };
+ note "ExtUtils::MakeMaker::Locale vars: $ExtUtils::MakeMaker::Locale::ENCODING_LOCALE;$ExtUtils::MakeMaker::Locale::ENCODING_LOCALE_FS;$ExtUtils::MakeMaker::Locale::ENCODING_CONSOLE_IN;$ExtUtils::MakeMaker::Locale::ENCODING_CONSOLE_OUT\n" unless $@;
+ note "Locale env vars: " . join(';', map {
+ "$_=$ENV{$_}"
+ } grep { /LANG|LC/ } keys %ENV) . "\n";
+}
+
+# Make sure when Makefile.PL's break, they issue a warning.
+# Also make sure Makefile.PL's in subdirs still have '.' in @INC.
+{
+ my $stdout = tie *STDOUT, 'TieOut' or die;
+
+ my $warning = '';
+ local $SIG{__WARN__} = sub { $warning .= join '', @_ };
+ $MM->eval_in_subdirs;
+ my $warnlines = grep { !/does not map to/ } split "\n", $warning;
+ is $warnlines, 0, 'no warning' or diag $warning;
+
+ open my $json_fh, '<:utf8', 'MYMETA.json' or die $!;
+ my $json = do { local $/; <$json_fh> };
+ close $json_fh;
+
+ require Encode;
+ my $str = Encode::decode( 'utf8', "Danijel Tašov's" );
+ like( $json, qr/$str/, 'utf8 abstract' );
+
+ untie *STDOUT;
+}
+
+my $make = make_run();
+my $make_out = run("$make");
+is $? >> 8, 0, 'Exit code of make == 0';
+
+my $manfile = File::Spec->catfile(qw(blib man1 probscript.1));
+SKIP: {
+ skip 'Manpage not generated', 1 unless -f $manfile;
+ skip 'Pod::Man >= 2.17 needed', 1 unless do {
+ require Pod::Man; $Pod::Man::VERSION >= 2.17;
+ };
+ open my $man_fh, '<:utf8', $manfile or die "open $manfile: $!";
+ my $man = do { local $/; <$man_fh> };
+ close $man_fh;
+
+ require Encode;
+ my $str = Encode::decode( 'utf8', "文档" );
+ like( $man, qr/$str/, 'utf8 man-snippet' );
+}
+
+$make_out = run("$make realclean");
+is $? >> 8, 0, 'Exit code of make == 0';
+
+sub makefile_content {
+ open my $fh, '<', makefile_name or die;
+ return <$fh>;
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+# test support for various forms of vstring versions in PREREQ_PM
+
+# Magic for core
+BEGIN {
+ # Always run in t to unify behaviour with core
+ chdir 't' if -d 't';
+}
+
+# Use things from t/lib/
+use lib './lib';
+use strict;
+use warnings;
+use TieOut;
+use MakeMaker::Test::Utils qw(makefile_name);
+use File::Temp qw[tempdir];
+
+use ExtUtils::MakeMaker;
+use Test::More;
+
+my $tmpdir = tempdir( DIR => '.', CLEANUP => 1 );
+chdir $tmpdir;
+
+sub capture_make {
+ my ($package, $version) = @_ ;
+
+ my $warnings = '';
+ local $SIG{__WARN__} = sub {
+ $warnings .= join '', @_;
+ };
+
+ local $ENV{PERL_CORE} = 0;
+
+ WriteMakefile(
+ NAME => 'VString::Test',
+ PREREQ_PM => { $package , $version }
+ );
+
+ return $warnings;
+}
+
+sub makefile_content {
+ open my $fh, '<', makefile_name or die;
+ return <$fh>;
+}
+
+# [ pkg, version, pattern, descrip, invertre ]
+my @DATA = (
+ [ DecimalString => '1.2.3', qr/isn't\s+numeric/, '3-part Decimal String' ],
+ [ VDecimalString => 'v1.2.3', qr/Unparsable\s+version/, '3-part V-Decimal String' ],
+ [ BareVString => v1.2.3, qr/Unparsable\s+version/, '3-part bare V-string' ],
+ [ VDecimalString => 'v1.2', qr/Unparsable\s+version/, '2-part v-decimal string' ],
+ [ BareVString => v1.2, qr/Unparsable\s+version/, '2-part bare v-string' ],
+ [ BrokenString => 'nan', qr/Unparsable\s+version/, 'random string', 1 ],
+);
+
+ok(my $stdout = tie *STDOUT, 'TieOut');
+for my $tuple (@DATA) {
+ my ($pkg, $version, $pattern, $descrip, $invertre) = @$tuple;
+ next if $] < 5.008 && $pkg eq 'BareVString' && $descrip =~ m!^2-part!;
+ my $out;
+ eval { $out = capture_make("Fake::$pkg" => $version); };
+ is($@, '', "$descrip not fatal");
+ if ($invertre) {
+ like ( $out , qr/$pattern/i, "$descrip parses");
+ } else {
+ unlike ( $out , qr/$pattern/i , "$descrip parses");
+ }
+# note(join q{}, grep { $_ =~ /Fake/i } makefile_content);
+}
+
+done_testing();
}
use strict;
+use Config;
use Test::More tests => 43;
use TieOut;
ok( my $stdout = tie *STDOUT, 'TieOut' );
my $warnings = '';
local $SIG{__WARN__} = sub {
+ if ( $Config{usecrosscompile} ) {
+ # libraries might not be present on the target system
+ # when cross-compiling
+ return if $_[0] =~ /\A\QWarning (mostly harmless): No library found for \E.+/
+ }
$warnings .= join '', @_;
};
# PERL_MM_OPT
{
- local $ENV{PERL_MM_OPT} = 'INSTALL_BASE="/Users/miyagawa/tmp/car1 foo/foo bar"';
+ local $ENV{PERL_MM_OPT} = 'INSTALL_BASE="/Users/miyagawa/tmp/car1 foo/foo bar"';
$mm = WriteMakefile(
NAME => 'Big::Dummy',
VERSION => '1.00',
);
- is( $mm->{INSTALL_BASE}, "/Users/miyagawa/tmp/car1 foo/foo bar", 'parse_args() splits like shell' );
+ is( $mm->{INSTALL_BASE}, "/Users/miyagawa/tmp/car1 foo/foo bar", 'parse_args() splits like shell' );
}
}
have_compiler()
? (tests => 5)
: (skip_all => "ExtUtils::CBuilder not installed or couldn't find a compiler");
-use File::Find;
use File::Spec;
-use File::Path;
my $Is_VMS = $^O eq 'VMS';
my $perl = which_perl();
diag("chdir failed: $!");
my @mpl_out = run(qq{$perl Makefile.PL});
-
-cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' ) ||
- diag(@mpl_out);
-
-my $make = make_run();
-my $make_out = run("$make");
-is( $?, 0, ' make exited normally' ) ||
- diag $make_out;
-
-my $test_out = run("$make test");
-is( $?, 0, ' make test exited normally' ) ||
- diag $test_out;
+SKIP: {
+ unless (cmp_ok( $?, '==', 0, 'Makefile.PL exited with zero' )) {
+ diag(@mpl_out);
+ skip 'perl Makefile.PL failed', 2;
+ }
+
+ my $make = make_run();
+ my $make_out = run("$make");
+ unless (is( $?, 0, ' make exited normally' )) {
+ diag $make_out;
+ skip 'Make failed - skipping test', 1;
+ }
+
+ my $test_out = run("$make test");
+ is( $?, 0, ' make test exited normally' ) ||
+ diag $test_out;
+}
\bBUILD.COM$
\bbuild.com$
+# and Module::Build::Tiny generated files
+\b_build_params$
+
# Avoid temp and backup files.
~$
\.old$
use File::Basename;
use File::Copy 'copy';
use File::Find;
-use File::Spec;
+use File::Spec 0.8;
use Carp;
use strict;
use warnings;
-our $VERSION = '1.68';
+our $VERSION = '1.69';
our @ISA = ('Exporter');
our @EXPORT_OK = qw(mkmanifest
manicheck filecheck fullcheck skipcheck
ExtUtils::Manifest - utilities to write and check a MANIFEST file
+=head1 VERSION
+
+version 1.69
+
=head1 SYNOPSIS
use ExtUtils::Manifest qw(...funcs to import...);
use strict;
use warnings;
# ABSTRACT: A small, simple, correct HTTP/1.1 client
-our $VERSION = '0.050'; # VERSION
+
+our $VERSION = '0.051';
use Carp ();
sub _agent {
my $class = ref($_[0]) || $_[0];
(my $default_agent = $class) =~ s{::}{-}g;
- return $default_agent . "/" . ($class->VERSION || 0);
+ return $default_agent . "/" . $class->VERSION;
}
sub _request {
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
. qq/Try installing Mozilla::CA from CPAN\n/;
}
+# for thread safety, we need to know thread id if threads are loaded
+sub _get_tid {
+ no warnings 'reserved'; # for 'threads'
+ return threads->can("tid") ? threads->tid : 0;
+}
+
sub _ssl_args {
my ($self, $host) = @_;
=head1 VERSION
-version 0.050
+version 0.051
=head1 SYNOPSIS
=head1 CONTRIBUTORS
-=for stopwords Alan Gardner Edward Zborowski James Raspass Jess Robinson Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Petr Písař Serguei Trouchelle Syohei YOSHIDA Alessandro Ghedini Sören Kornetzki Tom Hukins Tony Cook Brad Gilbert Chris Nehren Weyl Claes Jakobsson Clinton Gormley Craig Berry David Mitchell Dean Pearce
+=for stopwords Alan Gardner Alessandro Ghedini Brad Gilbert Chris Nehren Weyl Claes Jakobsson Clinton Gormley Craig Berry David Mitchell Dean Pearce Edward Zborowski James Raspass Jess Robinson Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Petr Písař Serguei Trouchelle Sören Kornetzki Syohei YOSHIDA Tom Hukins Tony Cook
=over 4
=item *
-Edward Zborowski <ed@rubensteintech.com>
+Alessandro Ghedini <al3xbio@gmail.com>
=item *
-James Raspass <jraspass@gmail.com>
+Brad Gilbert <bgills@cpan.org>
=item *
-Jess Robinson <castaway@desert-island.me.uk>
+Chris Nehren <apeiron@cpan.org>
=item *
-Lukas Eklund <leklund@gmail.com>
+Chris Weyl <cweyl@alumni.drew.edu>
=item *
-Martin J. Evans <mjegh@ntlworld.com>
+Claes Jakobsson <claes@surfar.nu>
=item *
-Martin-Louis Bright <mlbright@gmail.com>
+Clinton Gormley <clint@traveljury.com>
=item *
-Mike Doherty <doherty@cpan.org>
+Craig Berry <cberry@cpan.org>
=item *
-Petr Písař <ppisar@redhat.com>
+David Mitchell <davem@iabyn.com>
=item *
-Serguei Trouchelle <stro@cpan.org>
+Dean Pearce <pearce@pythian.com>
=item *
-Syohei YOSHIDA <syohex@gmail.com>
+Edward Zborowski <ed@rubensteintech.com>
=item *
-Alessandro Ghedini <al3xbio@gmail.com>
+James Raspass <jraspass@gmail.com>
=item *
-Sören Kornetzki <soeren.kornetzki@delti.com>
+Jess Robinson <castaway@desert-island.me.uk>
=item *
-Tom Hukins <tom@eborcom.com>
+Lukas Eklund <leklund@gmail.com>
=item *
-Tony Cook <tony@develop-help.com>
+Martin J. Evans <mjegh@ntlworld.com>
=item *
-Brad Gilbert <bgills@cpan.org>
+Martin-Louis Bright <mlbright@gmail.com>
=item *
-Chris Nehren <apeiron@cpan.org>
+Mike Doherty <doherty@cpan.org>
=item *
-Chris Weyl <rsrchboy@cpan.org>
+Petr Písař <ppisar@redhat.com>
=item *
-Claes Jakobsson <claes@surfar.nu>
+Serguei Trouchelle <stro@cpan.org>
=item *
-Clinton Gormley <clint@traveljury.com>
+Sören Kornetzki <soeren.kornetzki@delti.com>
=item *
-Craig Berry <cberry@cpan.org>
+Syohei YOSHIDA <syohex@gmail.com>
=item *
-David Mitchell <davem@iabyn.com>
+Tom Hukins <tom@eborcom.com>
=item *
-Dean Pearce <pearce@pythian.com>
+Tony Cook <tony@develop-help.com>
=back
use HTTP::Tiny;
BEGIN { monkey_patch() }
-for my $file ( dir_list("t/cases", qr/^get/ ) ) {
+for my $file ( dir_list("corpus", qr/^get/ ) ) {
my $label = basename($file);
my $data = do { local (@ARGV,$/) = $file; <> };
my ($params, $expect_req, $give_res) = split /--+\n/, $data;
use HTTP::Tiny;
BEGIN { monkey_patch() }
-for my $file ( dir_list("t/cases", qr/^head/ ) ) {
+for my $file ( dir_list("corpus", qr/^head/ ) ) {
my $data = do { local (@ARGV,$/) = $file; <> };
my ($params, $expect_req, $give_res) = split /--+\n/, $data;
# cleanup source data
use HTTP::Tiny;
BEGIN { monkey_patch() }
-for my $file ( dir_list("t/cases", qr/^put/ ) ) {
+for my $file ( dir_list("corpus", qr/^put/ ) ) {
my $data = do { local (@ARGV,$/) = $file; <> };
my ($params, $expect_req, $give_res) = split /--+\n/, $data;
# cleanup source data
use HTTP::Tiny;
BEGIN { monkey_patch() }
-for my $file ( dir_list("t/cases", qr/^delete/ ) ) {
+for my $file ( dir_list("corpus", qr/^delete/ ) ) {
my $data = do { local (@ARGV,$/) = $file; <> };
my ($params, $expect_req, $give_res) = split /--+\n/, $data;
# cleanup source data
use HTTP::Tiny;
BEGIN { monkey_patch() }
-for my $file ( dir_list("t/cases", qr/^post/ ) ) {
+for my $file ( dir_list("corpus", qr/^post/ ) ) {
my $data = do { local (@ARGV,$/) = $file; <> };
my ($params, $expect_req, $give_res) = split /--+\n/, $data;
# cleanup source data
'not-modified.txt' => $known_epoch - 2 * $day,
);
-for my $file ( dir_list("t/cases", qr/^mirror/ ) ) {
+for my $file ( dir_list("corpus", qr/^mirror/ ) ) {
1 while unlink $tempfile;
my $data = do { local (@ARGV,$/) = $file; <> };
my ($params, $expect_req, $give_res) = split /--+\n/, $data;
use HTTP::Tiny;
BEGIN { monkey_patch() }
-for my $file ( dir_list("t/cases", qr/^redirect/ ) ) {
+for my $file ( dir_list("corpus", qr/^redirect/ ) ) {
my $label = basename($file);
my $data = do { local (@ARGV,$/) = $file; <> };
my ($params, @case_pairs) = split /--+\n/, $data;
use HTTP::Tiny;
BEGIN { monkey_patch() }
-for my $file ( dir_list("t/cases", qr/^form/ ) ) {
+for my $file ( dir_list("corpus", qr/^form/ ) ) {
my $data = do { local (@ARGV,$/) = $file; <> };
my ($params, $expect_req, $give_res) = split /--+\n/, $data;
# cleanup source data
eval "require $class; 1"
or plan skip_all => "Needs $class";
- for my $file ( dir_list("t/cases", qr/^cookies/ ) ) {
+ for my $file ( dir_list("corpus", qr/^cookies/ ) ) {
my $label = basename($file);
my $data = do { local (@ARGV,$/) = $file; <> };
my @cases = split /--+\n/, $data;
use HTTP::Tiny;
BEGIN { monkey_patch() }
-for my $file ( dir_list("t/cases", qr/^auth/ ) ) {
+for my $file ( dir_list("corpus", qr/^auth/ ) ) {
my $label = basename($file);
my $data = do { local (@ARGV,$/) = $file; <> };
my ($params, @case_pairs) = split /--+\n/, $data;
use HTTP::Tiny;
BEGIN { monkey_patch() }
-for my $file ( dir_list("t/cases", qr/^proxy-auth/ ) ) {
+for my $file ( dir_list("corpus", qr/^proxy-auth/ ) ) {
my $label = basename($file);
my $data = do { local (@ARGV,$/) = $file; <> };
my ($params, @case_pairs) = split /--+\n/, $data;
$h->{handle}->close;
test_ht( "Socket closed", 0, 'http://foo.com' );
-for my $file ( dir_list( "t/cases", qr/^keepalive/ ) ) {
+for my $file ( dir_list( "corpus", qr/^keepalive/ ) ) {
my $label = basename($file);
my $data = do { local ( @ARGV, $/ ) = $file; <> };
my ( $title, $ok, $response ) = map { trim($_) } split /--+/, $data;
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
use constant GOT_TIME_HIRES => do {
eval 'use Time::HiRes qw(time);';
sub time_is_hires { return GOT_TIME_HIRES }
+=head3 C<get_times>
+
+Return array reference of the four-element list of CPU seconds,
+as with L<perlfunc/times>.
+
+=cut
+
+sub get_times { return [ times() ] }
+
1;
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
$self->_output_test_failure($parser);
}
else {
- my $time_report = '';
- if ( $formatter->timer ) {
- my $start_time = $parser->start_time;
- my $end_time = $parser->end_time;
- if ( defined $start_time and defined $end_time ) {
- my $elapsed = $end_time - $start_time;
- $time_report
- = $self->time_is_hires
- ? sprintf( ' %8d ms', $elapsed * 1000 )
- : sprintf( ' %8s s', $elapsed || '<1' );
- }
- }
-
+ my $time_report = $self->time_report($formatter, $parser);
$formatter->_output( $self->_make_ok_line($time_report) );
}
},
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
$self->_output_test_failure($parser);
}
else {
- my $time_report = '';
- if ( $formatter->timer ) {
- my $start_time = $parser->start_time;
- my $end_time = $parser->end_time;
- if ( defined $start_time and defined $end_time ) {
- my $elapsed = $end_time - $start_time;
- $time_report
- = $self->time_is_hires
- ? sprintf( ' %8d ms', $elapsed * 1000 )
- : sprintf( ' %8s s', $elapsed || '<1' );
- }
- }
-
+ my $time_report = $self->time_report($formatter, $parser);
$formatter->_output( $pretty
. ( $self->{results} ? "\n" . $self->{results} : "" )
. $self->_make_ok_line($time_report) );
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 METHODS
Called by C<close_test> to clear the line showing test progress, or the parallel
test ruler, prior to printing the final test result.
+=head3 C<time_report>
+
+Return a formatted string about the elapsed (wall-clock) time
+and about the consumed CPU time.
+
=cut
sub header { }
return "ok$suffix\n";
}
+sub time_report {
+ my ( $self, $formatter, $parser ) = @_;
+
+ my @time_report;
+ if ( $formatter->timer ) {
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time;
+ if ( defined $start_time and defined $end_time ) {
+ my $elapsed = $end_time - $start_time;
+ push @time_report,
+ $self->time_is_hires
+ ? sprintf( ' %8d ms', $elapsed * 1000 )
+ : sprintf( ' %8s s', $elapsed || '<1' );
+ }
+ my $start_times = $parser->start_times();
+ my $end_times = $parser->end_times();
+ my $usr = $end_times->[0] - $start_times->[0];
+ my $sys = $end_times->[1] - $start_times->[1];
+ my $cusr = $end_times->[2] - $start_times->[2];
+ my $csys = $end_times->[3] - $start_times->[3];
+ push @time_report,
+ sprintf('(%5.2f usr %5.2f sys + %5.2f cusr %5.2f csys = %5.2f CPU)',
+ $usr, $sys, $cusr, $csys,
+ $usr + $sys + $cusr + $csys);
+ }
+
+ return "@time_report";
+}
+
1;
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
$ENV{HARNESS_ACTIVE} = 1;
$ENV{HARNESS_VERSION} = $VERSION;
use TAP::Object;
use Text::ParseWords qw/shellwords/;
-our $VERSION = '3.33';
+our $VERSION = '3.34';
# Get the parts of @INC which are changed from the stock list AND
# preserve reordering of stock directories.
=head1 VERSION
-Version 3.33
+Version 3.34
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
my $DEFAULT_TAP_VERSION = 12;
my $MAX_TAP_VERSION = 13;
in_todo
start_time
end_time
+ start_times
+ end_times
skip_all
grammar_class
result_factory_class
=head3 C<start_time>
-Returns the time when the Parser was created.
+Returns the wall-clock time when the Parser was created.
=head3 C<end_time>
-Returns the time when the end of TAP input was seen.
+Returns the wall-clock time when the end of TAP input was seen.
+
+=head3 C<start_times>
+
+Returns the CPU times (like L<perlfunc/times> when the Parser was created.
+
+=head3 C<end_times>
+
+Returns the CPU times (like L<perlfunc/times> when the end of TAP
+input was seen.
=head3 C<has_problems>
my $state_table = $self->_make_state_table;
$self->start_time( $self->get_time );
+ $self->start_times( $self->get_times );
# Make next_state closure
my $next_state = sub {
my $self = shift;
$self->end_time( $self->get_time );
+ $self->end_times( $self->get_times );
# Avoid leaks
$self->_iterator(undef);
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head2 DESCRIPTION
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
=head1 SYNOPSIS
use base 'TAP::Object';
-our $VERSION = '3.33';
+our $VERSION = '3.34';
# TODO:
# Handle blessed object syntax
=head1 VERSION
-Version 3.33
+Version 3.34
=head1 SYNOPSIS
use base 'TAP::Object';
-our $VERSION = '3.33';
+our $VERSION = '3.34';
my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
=head1 VERSION
-Version 3.33
+Version 3.34
=head1 SYNOPSIS
=head1 VERSION
-Version 3.33
+Version 3.34
=cut
-our $VERSION = '3.33';
+our $VERSION = '3.34';
# Backwards compatibility for exportable variable names.
*verbose = *Verbose;
# Check that PERL5LIB is propagated to -T.
{
my $sentinel_dir = 'i/do/not/exist';
- local $ENV{PERL5LIB} = join $Config{path_sep}, $ENV{PERL5LIB}, $sentinel_dir;
+ local $ENV{PERL5LIB} = join $Config{path_sep}, $ENV{PERL5LIB} || '', $sentinel_dir;
run_test_file(sprintf <<'END', $sentinel_dir);
#!/usr/bin/perl -T
package Test::Builder;
-use 5.006;
+use 5.008001;
use strict;
use warnings;
-our $VERSION = '1.001008';
+our $VERSION = '1.301001_075';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-BEGIN {
- if( $] < 5.008 ) {
- require Test::Builder::IO::Scalar;
- }
-}
-
-# Make Test::Builder thread-safe for ithreads.
-BEGIN {
- use Config;
- # Load threads::shared when threads are turned on.
- # 5.8.0's threads are so busted we no longer support them.
- if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
- require threads::shared;
-
- # Hack around YET ANOTHER threads::shared bug. It would
- # occasionally forget the contents of the variable when sharing it.
- # So we first copy the data, then share, then put our copy back.
- *share = sub (\[$@%]) {
- my $type = ref $_[0];
- my $data;
-
- if( $type eq 'HASH' ) {
- %$data = %{ $_[0] };
- }
- elsif( $type eq 'ARRAY' ) {
- @$data = @{ $_[0] };
- }
- elsif( $type eq 'SCALAR' ) {
- $$data = ${ $_[0] };
- }
- else {
- die( "Unknown type: " . $type );
- }
+use Test::Stream 1.301001 qw/ -internal STATE_LEGACY STATE_PLAN STATE_COUNT /;
+use Test::Stream::Toolset;
+use Test::Stream::Context;
+use Test::Stream::Carp qw/confess/;
+use Test::Stream::Meta qw/MODERN/;
- $_[0] = &threads::shared::share( $_[0] );
+use Test::Stream::Util qw/try protect unoverload_str is_regex/;
+use Scalar::Util qw/blessed reftype/;
- if( $type eq 'HASH' ) {
- %{ $_[0] } = %$data;
- }
- elsif( $type eq 'ARRAY' ) {
- @{ $_[0] } = @$data;
- }
- elsif( $type eq 'SCALAR' ) {
- ${ $_[0] } = $$data;
- }
- else {
- die( "Unknown type: " . $type );
- }
+use Test::More::Tools;
- return $_[0];
- };
- }
- # 5.8.0's threads::shared is busted when threads are off
- # and earlier Perls just don't have that module at all.
- else {
- *share = sub { return $_[0] };
- *lock = sub { 0 };
- }
+BEGIN {
+ my $meta = Test::Stream::Meta->is_tester('main');
+ Test::Stream->shared->set_use_legacy(1)
+ unless $meta && $meta->[MODERN];
}
-=head1 NAME
-
-Test::Builder - Backend for building test libraries
-
-=head1 SYNOPSIS
-
- package My::Test::Module;
- use base 'Test::Builder::Module';
-
- my $CLASS = __PACKAGE__;
-
- sub ok {
- my($test, $name) = @_;
- my $tb = $CLASS->builder;
-
- $tb->ok($test, $name);
- }
+# The mostly-singleton, and other package vars.
+our $Test = Test::Builder->new;
+our $_ORIG_Test = $Test;
+our $Level = 1;
+sub ctx {
+ my $self = shift || die "No self in context";
+ my ($add) = @_;
+ my $ctx = Test::Stream::Context::context(2 + ($add || 0), $self->{stream});
+ if (defined $self->{Todo}) {
+ $ctx->set_in_todo(1);
+ $ctx->set_todo($self->{Todo});
+ $ctx->set_diag_todo(1);
+ }
+ return $ctx;
+}
-=head1 DESCRIPTION
+sub stream {
+ my $self = shift;
+ return $self->{stream} || Test::Stream->shared;
+}
-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>.
+sub depth { $_[0]->{depth} || 0 }
-=head2 Construction
+# This is only for unit tests at this point.
+sub _ending {
+ my $self = shift;
+ my ($ctx) = @_;
+ require Test::Stream::ExitMagic;
+ $self->{stream}->set_no_ending(0);
+ Test::Stream::ExitMagic->new->do_magic($self->{stream}, $ctx);
+}
+
+my %WARNED;
+our $CTX;
+our %ORIG = (
+ ok => \&ok,
+ diag => \&diag,
+ note => \¬e,
+ plan => \&plan,
+ done_testing => \&done_testing,
+);
-=over 4
+sub WARN_OF_OVERRIDE {
+ my ($sub, $ctx) = @_;
-=item B<new>
+ return unless $ctx->modern;
+ my $old = $ORIG{$sub};
+ # Use package instead of self, we want replaced subs, not subclass overrides.
+ my $new = __PACKAGE__->can($sub);
- my $Test = Test::Builder->new;
+ return if $new == $old;
-Returns a Test::Builder object representing the current state of the
-test.
+ require B;
+ my $o = B::svref_2object($new);
+ my $gv = $o->GV;
+ my $st = $o->START;
+ my $name = $gv->NAME;
+ my $pkg = $gv->STASH->NAME;
+ my $line = $st->line;
+ my $file = $st->file;
-Since you only run one test per program C<new> always returns the same
-Test::Builder object. No matter how many times you call C<new()>, you're
-getting the same object. This is called a singleton. This is done so that
-multiple modules share such global information as the test counter and
-where test output is going.
+ warn <<" EOT" unless $WARNED{"$pkg $name $file $line"}++;
-If you want a completely new Test::Builder object different from the
-singleton, use C<create>.
+*******************************************************************************
+Something monkeypatched Test::Builder::$sub()!
+The new sub is '$pkg\::$name' defined in $file around line $line.
+In the near future monkeypatching Test::Builder::ok() will no longer work
+as expected.
+*******************************************************************************
+ EOT
+}
-=cut
-our $Test = Test::Builder->new;
+####################
+# {{{ Constructors #
+####################
sub new {
- my($class) = shift;
- $Test ||= $class->create;
+ my $class = shift;
+ my %params = @_;
+ $Test ||= $class->create(shared_stream => 1);
+
return $Test;
}
-=item B<create>
-
- my $Test = Test::Builder->create;
-
-Ok, so there can be more than one Test::Builder object and this is how
-you get it. You might use this instead of C<new()> if you're testing
-a Test::Builder based module, but otherwise you probably want C<new>.
-
-B<NOTE>: the implementation is not complete. C<level>, for example, is
-still shared amongst B<all> Test::Builder objects, even ones created using
-this method. Also, the method name may change in the future.
-
-=cut
-
sub create {
- my $class = shift;
+ my $class = shift;
+ my %params = @_;
my $self = bless {}, $class;
- $self->reset;
+ $self->reset(%params);
return $self;
}
-
# Copy an object, currently a shallow.
# This does *not* bless the destination. This keeps the destructor from
# firing when we're just storing a copy of the object to restore later.
sub _copy {
- my($src, $dest) = @_;
-
+ my ($src, $dest) = @_;
%$dest = %$src;
- _share_keys($dest);
-
return;
}
+####################
+# }}} Constructors #
+####################
-=item B<child>
-
- my $child = $builder->child($name_of_child);
- $child->plan( tests => 4 );
- $child->ok(some_code());
- ...
- $child->finalize;
+#############################
+# {{{ Children and subtests #
+#############################
-Returns a new instance of C<Test::Builder>. Any output from this child will
-be indented four spaces more than the parent's indentation. When done, the
-C<finalize> method I<must> be called explicitly.
-
-Trying to create a new child with a previous child still active (i.e.,
-C<finalize> not called) will C<croak>.
-
-Trying to run a test when you have an open child will also C<croak> and cause
-the test suite to fail.
-
-=cut
+sub subtest {
+ my $self = shift;
+ my $ctx = $self->ctx();
+ return tmt->subtest(@_);
+}
sub child {
my( $self, $name ) = @_;
- if( $self->{Child_Name} ) {
- $self->croak("You already have a child named ($self->{Child_Name}) running");
- }
-
- my $parent_in_todo = $self->in_todo;
+ my $ctx = $self->ctx;
- # Clear $TODO for the child.
- my $orig_TODO = $self->find_TODO(undef, 1, undef);
+ if ($self->{child}) {
+ my $cname = $self->{child}->{Name};
+ $ctx->throw("You already have a child named ($cname) running");
+ }
- my $class = ref $self;
- my $child = $class->create;
+ $name ||= "Child of " . $self->{Name};
+ $ctx->child('push', $name, 1);
- # Add to our indentation
- $child->_indent( $self->_indent . ' ' );
+ my $stream = $self->{stream} || Test::Stream->shared;
- # Make the child use the same outputs as the parent
- for my $method (qw(output failure_output todo_output)) {
- $child->$method( $self->$method );
- }
+ my $child = bless {
+ %$self,
+ '?' => $?,
+ parent => $self,
+ };
- # Ensure the child understands if they're inside a TODO
- if( $parent_in_todo ) {
- $child->failure_output( $self->todo_output );
- }
+ $? = 0;
+ $child->{Name} = $name;
+ $self->{child} = $child;
+ Scalar::Util::weaken($self->{child});
- # This will be reset in finalize. We do this here lest one child failure
- # cause all children to fail.
- $child->{Child_Error} = $?;
- $? = 0;
- $child->{Parent} = $self;
- $child->{Parent_TODO} = $orig_TODO;
- $child->{Name} = $name || "Child of " . $self->name;
- $self->{Child_Name} = $child->name;
return $child;
}
-
-=item B<subtest>
-
- $builder->subtest($name, \&subtests, @args);
-
-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 {
+sub finalize {
my $self = shift;
- my($name, $subtests, @args) = @_;
- if ('CODE' ne ref $subtests) {
- $self->croak("subtest()'s second argument must be a code ref");
- }
+ return unless $self->{parent};
- # Turn the child into the parent so anyone who has stored a copy of
- # the Test::Builder singleton will get the child.
- my $error;
- my $child;
- my $parent = {};
- {
- # child() calls reset() which sets $Level to 1, so we localize
- # $Level first to limit the scope of the reset to the subtest.
- local $Test::Builder::Level = $Test::Builder::Level + 1;
-
- # Store the guts of $self as $parent and turn $child into $self.
- $child = $self->child($name);
- _copy($self, $parent);
- _copy($child, $self);
-
- my $run_the_subtests = sub {
- # Add subtest name for clarification of starting point
- $self->note("Subtest: $name");
- $subtests->(@args);
- $self->done_testing unless $self->_plan_handled;
- 1;
- };
-
- if( !eval { $run_the_subtests->() } ) {
- $error = $@;
- }
- }
+ my $ctx = $self->ctx;
- # Restore the parent and the copied child.
- _copy($self, $child);
- _copy($parent, $self);
+ if ($self->{child}) {
+ my $cname = $self->{child}->{Name};
+ $ctx->throw("Can't call finalize() with child ($cname) active");
+ }
- # Restore the parent's $TODO
- $self->find_TODO(undef, 1, $child->{Parent_TODO});
+ $self->_ending($ctx);
+ my $passing = $ctx->stream->is_passing;
+ my $count = $ctx->stream->count;
+ my $name = $self->{Name};
+ $ctx = undef;
- # Die *after* we restore the parent.
- die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
+ my $stream = $self->{stream} || Test::Stream->shared;
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- my $finalize = $child->finalize;
+ my $parent = $self->parent;
+ $self->{parent}->{child} = undef;
+ $self->{parent} = undef;
- $self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out};
+ $? = $self->{'?'};
- return $finalize;
+ $ctx = $parent->ctx;
+ $ctx->child('pop', $self->{Name});
}
-=begin _private
-
-=item B<_plan_handled>
-
- if ( $Test->_plan_handled ) { ... }
-
-Returns true if the developer has explicitly handled the plan via:
-
-=over 4
-
-=item * Explicitly setting the number of tests
-
-=item * Setting 'no_plan'
-
-=item * Set 'skip_all'.
-
-=back
-
-This is currently used in subtests when we implicitly call C<< $Test->done_testing >>
-if the developer has not set a plan.
-
-=end _private
+sub in_subtest {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ return scalar @{$ctx->stream->subtests};
+}
-=cut
+sub parent { $_[0]->{parent} }
+sub name { $_[0]->{Name} }
-sub _plan_handled {
+sub DESTROY {
my $self = shift;
- return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
+ return unless $self->{parent};
+ return if $self->{Skip_All};
+ $self->{parent}->is_passing(0);
+ my $name = $self->{Name};
+ die "Child ($name) exited without calling finalize()";
}
+#############################
+# }}} Children and subtests #
+#############################
+
+#####################################
+# {{{ stuff for TODO status #
+#####################################
-=item B<finalize>
+sub find_TODO {
+ my ($self, $pack, $set, $new_value) = @_;
+
+ unless ($pack) {
+ if (my $ctx = Test::Stream::Context->peek) {
+ $pack = $ctx->package;
+ my $old = $ctx->todo;
+ $ctx->set_todo($new_value) if $set;
+ return $old;
+ }
- my $ok = $child->finalize;
+ $pack = $self->exported_to || return;
+ }
-When your child is done running tests, you must call C<finalize> to clean up
-and tell the parent your pass/fail status.
+ no strict 'refs'; ## no critic
+ no warnings 'once';
+ my $old_value = ${$pack . '::TODO'};
+ $set and ${$pack . '::TODO'} = $new_value;
+ return $old_value;
+}
-Calling C<finalize> on a child with open children will C<croak>.
+sub todo {
+ my ($self, $pack) = @_;
-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.
+ return $self->{Todo} if defined $self->{Todo};
-No attempt to call methods on a child after C<finalize> is called is
-guaranteed to succeed.
+ my $ctx = $self->ctx;
-Calling this on the root builder is a no-op.
+ my $todo = $self->find_TODO($pack);
+ return $todo if defined $todo;
-=cut
+ return '';
+}
-sub finalize {
+sub in_todo {
my $self = shift;
- return unless $self->parent;
- if( $self->{Child_Name} ) {
- $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
- }
+ my $ctx = $self->ctx;
+ return 1 if $ctx->in_todo;
- local $? = 0; # don't fail if $subtests happened to set $? nonzero
- $self->_ending;
+ return (defined $self->{Todo} || $self->find_TODO) ? 1 : 0;
+}
- # XXX This will only be necessary for TAP envelopes (we think)
- #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
+sub todo_start {
+ my $self = shift;
+ my $message = @_ ? shift : '';
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- my $ok = 1;
- $self->parent->{Child_Name} = undef;
- unless ($self->{Bailed_Out}) {
- if ( $self->{Skip_All} ) {
- $self->parent->skip($self->{Skip_All}, $self->name);
- }
- elsif ( not @{ $self->{Test_Results} } ) {
- $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
- }
- else {
- $self->parent->ok( $self->is_passing, $self->name );
- }
+ $self->{Start_Todo}++;
+ if ($self->in_todo) {
+ push @{$self->{Todo_Stack}} => $self->todo;
}
- $? = $self->{Child_Error};
- delete $self->{Parent};
+ $self->{Todo} = $message;
- return $self->is_passing;
+ return;
}
-sub _indent {
+sub todo_end {
my $self = shift;
- if( @_ ) {
- $self->{Indent} = shift;
+ if (!$self->{Start_Todo}) {
+ $self->ctx(-1)->throw('todo_end() called without todo_start()');
}
- return $self->{Indent};
-}
-
-=item B<parent>
-
- if ( my $parent = $builder->parent ) {
- ...
- }
+ $self->{Start_Todo}--;
-Returns the parent C<Test::Builder> instance, if any. Only used with child
-builders for nested TAP.
+ if ($self->{Start_Todo} && @{$self->{Todo_Stack}}) {
+ $self->{Todo} = pop @{$self->{Todo_Stack}};
+ }
+ else {
+ delete $self->{Todo};
+ }
-=cut
+ return;
+}
-sub parent { shift->{Parent} }
+#####################################
+# }}} Finding Testers and Providers #
+#####################################
-=item B<name>
+################
+# {{{ Planning #
+################
- diag $builder->name;
+my %PLAN_CMDS = (
+ no_plan => 'no_plan',
+ skip_all => 'skip_all',
+ tests => '_plan_tests',
+);
-Returns the name of the current builder. Top level builders default to C<$0>
-(the name of the executable). Child builders are named via the C<child>
-method. If no name is supplied, will be named "Child of $parent->name".
+sub plan {
+ my ($self, $cmd, @args) = @_;
-=cut
+ my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
+ WARN_OF_OVERRIDE(plan => $ctx);
-sub name { shift->{Name} }
+ return unless $cmd;
-sub DESTROY {
- my $self = shift;
- if ( $self->parent and $$ == $self->{Original_Pid} ) {
- my $name = $self->name;
- $self->diag(<<"FAIL");
-Child ($name) exited without calling finalize()
-FAIL
- $self->parent->{In_Destroy} = 1;
- $self->parent->ok(0, $name);
+ if (my $method = $PLAN_CMDS{$cmd}) {
+ $self->$method(@args);
+ }
+ else {
+ my @in = grep { defined } ($cmd, @args);
+ $self->ctx->throw("plan() doesn't understand @in");
}
-}
-=item B<reset>
+ return 1;
+}
- $Test->reset;
+sub skip_all {
+ my ($self, $reason) = @_;
-Reinitializes the Test::Builder singleton to its original state.
-Mostly useful for tests run in persistent environments where the same
-test might be run multiple times in the same process.
+ $self->{Skip_All} = 1;
-=cut
+ my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
-our $Level;
+ $ctx->_plan(0, 'SKIP', $reason);
+}
-sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
- my($self) = @_;
+sub no_plan {
+ my ($self, @args) = @_;
- # We leave this a global because it has to be localized and localizing
- # hash keys is just asking for pain. Also, it was documented.
- $Level = 1;
+ my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
- $self->{Name} = $0;
- $self->is_passing(1);
- $self->{Ending} = 0;
- $self->{Have_Plan} = 0;
- $self->{No_Plan} = 0;
- $self->{Have_Output_Plan} = 0;
- $self->{Done_Testing} = 0;
+ $ctx->alert("no_plan takes no arguments") if @args;
+ $ctx->_plan(0, 'NO PLAN');
- $self->{Original_Pid} = $$;
- $self->{Child_Name} = undef;
- $self->{Indent} ||= '';
+ return 1;
+}
- $self->{Curr_Test} = 0;
- $self->{Test_Results} = &share( [] );
+sub _plan_tests {
+ my ($self, $arg) = @_;
- $self->{Exported_To} = undef;
- $self->{Expected_Tests} = 0;
+ my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
- $self->{Skip_All} = 0;
+ if ($arg) {
+ $ctx->throw("Number of tests must be a positive integer. You gave it '$arg'")
+ unless $arg =~ /^\+?\d+$/;
- $self->{Use_Nums} = 1;
+ $ctx->_plan($arg);
+ }
+ elsif (!defined $arg) {
+ $ctx->throw("Got an undefined number of tests");
+ }
+ else {
+ $ctx->throw("You said to run 0 tests");
+ }
- $self->{No_Header} = 0;
- $self->{No_Ending} = 0;
+ return;
+}
- $self->{Todo} = undef;
- $self->{Todo_Stack} = [];
- $self->{Start_Todo} = 0;
- $self->{Opened_Testhandles} = 0;
+sub done_testing {
+ my ($self, $num_tests) = @_;
- $self->_share_keys;
- $self->_dup_stdhandles;
+ my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
+ WARN_OF_OVERRIDE(done_testing => $ctx);
- return;
+ my $out = $ctx->stream->done_testing($ctx, $num_tests);
+ return $out;
}
+################
+# }}} Planning #
+################
+
+#############################
+# {{{ Base Event Producers #
+#############################
-# Shared scalar values are lost when a hash is copied, so we have
-# a separate method to restore them.
-# Shared references are retained across copies.
-sub _share_keys {
+sub ok {
my $self = shift;
+ my($test, $name) = @_;
- share( $self->{Curr_Test} );
+ my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
+ WARN_OF_OVERRIDE(ok => $ctx);
- return;
+ if ($self->{child}) {
+ $self->is_passing(0);
+ $ctx->throw("Cannot run test ($name) with active children");
+ }
+
+ $ctx->_unwind_ok($test, $name);
+ return $test ? 1 : 0;
}
+sub BAIL_OUT {
+ my( $self, $reason ) = @_;
+ $self->ctx()->bail($reason);
+}
-=back
+sub skip {
+ my( $self, $why ) = @_;
+ $why ||= '';
+ unoverload_str( \$why );
-=head2 Setting up tests
+ my $ctx = $self->ctx();
+ $ctx->set_skip($why);
+ $ctx->ok(1, '');
+ $ctx->set_skip(undef);
+}
-These methods are for setting up tests and declaring how many there
-are. You usually only want to call one of these methods.
+sub todo_skip {
+ my( $self, $why ) = @_;
+ $why ||= '';
+ unoverload_str( \$why );
-=over 4
+ my $ctx = $self->ctx();
+ $ctx->set_skip($why);
+ $ctx->set_todo($why);
+ $ctx->ok(0, '');
+ $ctx->set_skip(undef);
+ $ctx->set_todo(undef);
+}
-=item B<plan>
+sub diag {
+ my $self = shift;
+ my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
- $Test->plan('no_plan');
- $Test->plan( skip_all => $reason );
- $Test->plan( tests => $num_tests );
+ my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
+ WARN_OF_OVERRIDE(diag => $ctx);
-A convenient way to set up your tests. Call this and Test::Builder
-will print the appropriate headers and take the appropriate actions.
+ $ctx->_diag($msg);
+ return;
+}
-If you call C<plan()>, don't call any of the other methods below.
+sub note {
+ my $self = shift;
+ my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
-If a child calls "skip_all" in the plan, a C<Test::Builder::Exception> is
-thrown. Trap this error, call C<finalize()> and don't run any more tests on
-the child.
+ my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
+ WARN_OF_OVERRIDE(note => $ctx);
- my $child = $Test->child('some child');
- eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 ) ) };
- if ( eval { $@->isa('Test::Builder::Exception') } ) {
- $child->finalize;
- return;
- }
- # run your tests
+ $ctx->_note($msg);
+}
-=cut
+#############################
+# }}} Base Event Producers #
+#############################
-my %plan_cmds = (
- no_plan => \&no_plan,
- skip_all => \&skip_all,
- tests => \&_plan_tests,
-);
+#######################
+# {{{ Public helpers #
+#######################
-sub plan {
- my( $self, $cmd, $arg ) = @_;
+sub explain {
+ my $self = shift;
- return unless $cmd;
+ return map {
+ ref $_
+ ? do {
+ protect { require Data::Dumper };
+ my $dumper = Data::Dumper->new( [$_] );
+ $dumper->Indent(1)->Terse(1);
+ $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
+ $dumper->Dump;
+ }
+ : $_
+ } @_;
+}
- local $Level = $Level + 1;
+sub carp {
+ my $self = shift;
+ $self->ctx->alert(join '' => @_);
+}
- $self->croak("You tried to plan twice") if $self->{Have_Plan};
+sub croak {
+ my $self = shift;
+ $self->ctx->throw(join '' => @_);
+}
- if( my $method = $plan_cmds{$cmd} ) {
- local $Level = $Level + 1;
- $self->$method($arg);
- }
- else {
- my @args = grep { defined } ( $cmd, $arg );
- $self->croak("plan() doesn't understand @args");
- }
+sub has_plan {
+ my $self = shift;
- return 1;
+ my $plan = $self->ctx->stream->plan || return undef;
+ return 'no_plan' if $plan->directive && $plan->directive eq 'NO PLAN';
+ return $plan->max;
}
+sub reset {
+ my $self = shift;
+ my %params = @_;
-sub _plan_tests {
- my($self, $arg) = @_;
+ $self->{use_shared} = 1 if $params{shared_stream};
- if($arg) {
- local $Level = $Level + 1;
- return $self->expected_tests($arg);
- }
- elsif( !defined $arg ) {
- $self->croak("Got an undefined number of tests");
+ if ($self->{use_shared}) {
+ Test::Stream->shared->_reset;
+ Test::Stream->shared->state->[-1]->[STATE_LEGACY] = [];
}
else {
- $self->croak("You said to run 0 tests");
+ $self->{stream} = Test::Stream->new();
+ $self->{stream}->set_use_legacy(1);
+ $self->{stream}->state->[-1]->[STATE_LEGACY] = [];
}
- return;
-}
-
-=item B<expected_tests>
-
- my $max = $Test->expected_tests;
- $Test->expected_tests($max);
-
-Gets/sets the number of tests we expect this test to run and prints out
-the appropriate headers.
+ # We leave this a global because it has to be localized and localizing
+ # hash keys is just asking for pain. Also, it was documented.
+ $Level = 1;
-=cut
+ $self->{Name} = $0;
-sub expected_tests {
- my $self = shift;
- my($max) = @_;
+ $self->{Original_Pid} = $$;
+ $self->{Child_Name} = undef;
- if(@_) {
- $self->croak("Number of tests must be a positive integer. You gave it '$max'")
- unless $max =~ /^\+?\d+$/;
+ $self->{Exported_To} = undef;
- $self->{Expected_Tests} = $max;
- $self->{Have_Plan} = 1;
+ $self->{Todo} = undef;
+ $self->{Todo_Stack} = [];
+ $self->{Start_Todo} = 0;
+ $self->{Opened_Testhandles} = 0;
- $self->_output_plan($max) unless $self->no_header;
- }
- return $self->{Expected_Tests};
+ return;
}
-=item B<no_plan>
+#######################
+# }}} Public helpers #
+#######################
- $Test->no_plan;
+#################################
+# {{{ Advanced Event Producers #
+#################################
-Declares that this test will run an indeterminate number of tests.
+sub cmp_ok {
+ my( $self, $got, $type, $expect, $name ) = @_;
+ my $ctx = $self->ctx;
+ my ($ok, @diag) = tmt->cmp_check($got, $type, $expect);
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
-=cut
+sub is_eq {
+ my( $self, $got, $expect, $name ) = @_;
+ my $ctx = $self->ctx;
+ my ($ok, @diag) = tmt->is_eq($got, $expect);
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
-sub no_plan {
- my($self, $arg) = @_;
+sub is_num {
+ my( $self, $got, $expect, $name ) = @_;
+ my $ctx = $self->ctx;
+ my ($ok, @diag) = tmt->is_num($got, $expect);
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
- $self->carp("no_plan takes no arguments") if $arg;
+sub isnt_eq {
+ my( $self, $got, $dont_expect, $name ) = @_;
+ my $ctx = $self->ctx;
+ my ($ok, @diag) = tmt->isnt_eq($got, $dont_expect);
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
- $self->{No_Plan} = 1;
- $self->{Have_Plan} = 1;
+sub isnt_num {
+ my( $self, $got, $dont_expect, $name ) = @_;
+ my $ctx = $self->ctx;
+ my ($ok, @diag) = tmt->isnt_num($got, $dont_expect);
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
- return 1;
+sub like {
+ my( $self, $thing, $regex, $name ) = @_;
+ my $ctx = $self->ctx;
+ my ($ok, @diag) = tmt->regex_check($thing, $regex, '=~');
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
}
-=begin private
+sub unlike {
+ my( $self, $thing, $regex, $name ) = @_;
+ my $ctx = $self->ctx;
+ my ($ok, @diag) = tmt->regex_check($thing, $regex, '!~');
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
-=item B<_output_plan>
+#################################
+# }}} Advanced Event Producers #
+#################################
- $tb->_output_plan($max);
- $tb->_output_plan($max, $directive);
- $tb->_output_plan($max, $directive => $reason);
+################################################
+# {{{ Misc #
+################################################
-Handles displaying the test plan.
-
-If a C<$directive> and/or C<$reason> are given they will be output with the
-plan. So here's what skipping all tests looks like:
-
- $tb->_output_plan(0, "SKIP", "Because I said so");
-
-It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already
-output.
-
-=end private
-
-=cut
-
-sub _output_plan {
- my($self, $max, $directive, $reason) = @_;
-
- $self->carp("The plan was already output") if $self->{Have_Output_Plan};
-
- my $plan = "1..$max";
- $plan .= " # $directive" if defined $directive;
- $plan .= " $reason" if defined $reason;
-
- $self->_print("$plan\n");
-
- $self->{Have_Output_Plan} = 1;
-
- return;
-}
-
-
-=item B<done_testing>
-
- $Test->done_testing();
- $Test->done_testing($num_tests);
-
-Declares that you are done testing, no more tests will be run after this point.
-
-If a plan has not yet been output, it will do so.
-
-$num_tests is the number of tests you planned to run. If a numbered
-plan was already declared, and if this contradicts, a failing test
-will be run to reflect the planning mistake. If C<no_plan> was declared,
-this will override.
-
-If C<done_testing()> is called twice, the second call will issue a
-failing test.
-
-If C<$num_tests> is omitted, the number of tests run will be used, like
-no_plan.
-
-C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
-safer. You'd use it like so:
-
- $Test->ok($a == $b);
- $Test->done_testing();
-
-Or to plan a variable number of tests:
-
- for my $test (@tests) {
- $Test->ok($test);
- }
- $Test->done_testing(scalar @tests);
-
-=cut
-
-sub done_testing {
- my($self, $num_tests) = @_;
-
- # If done_testing() specified the number of tests, shut off no_plan.
- if( defined $num_tests ) {
- $self->{No_Plan} = 0;
- }
- else {
- $num_tests = $self->current_test;
- }
-
- if( $self->{Done_Testing} ) {
- my($file, $line) = @{$self->{Done_Testing}}[1,2];
- $self->ok(0, "done_testing() was already called at $file line $line");
- return;
- }
-
- $self->{Done_Testing} = [caller];
-
- if( $self->expected_tests && $num_tests != $self->expected_tests ) {
- $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
- "but done_testing() expects $num_tests");
- }
- else {
- $self->{Expected_Tests} = $num_tests;
- }
-
- $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
-
- $self->{Have_Plan} = 1;
-
- # The wrong number of tests were run
- $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
-
- # No tests were run
- $self->is_passing(0) if $self->{Curr_Test} == 0;
-
- return 1;
-}
-
-
-=item B<has_plan>
-
- $plan = $Test->has_plan
-
-Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
-has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
-of expected tests).
-
-=cut
-
-sub has_plan {
+sub _new_fh {
my $self = shift;
+ my($file_or_fh) = shift;
- return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
- return('no_plan') if $self->{No_Plan};
- return(undef);
-}
-
-=item B<skip_all>
-
- $Test->skip_all;
- $Test->skip_all($reason);
-
-Skips all the tests, using the given C<$reason>. Exits immediately with 0.
-
-=cut
-
-sub skip_all {
- my( $self, $reason ) = @_;
-
- $self->{Skip_All} = $self->parent ? $reason : 1;
-
- $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
- if ( $self->parent ) {
- die bless {} => 'Test::Builder::Exception';
- }
- exit(0);
-}
-
-=item B<exported_to>
-
- my $pack = $Test->exported_to;
- $Test->exported_to($pack);
-
-Tells Test::Builder what package you exported your functions to.
-
-This method isn't terribly useful since modules which share the same
-Test::Builder object might get exported to different packages and only
-the last one will be honored.
-
-=cut
-
-sub exported_to {
- my( $self, $pack ) = @_;
-
- if( defined $pack ) {
- $self->{Exported_To} = $pack;
- }
- return $self->{Exported_To};
-}
-
-=back
-
-=head2 Running tests
-
-These actually run the tests, analogous to the functions in Test::More.
-
-They all return true if the test passed, false if the test failed.
-
-C<$name> is always optional.
-
-=over 4
-
-=item B<ok>
-
- $Test->ok($test, $name);
-
-Your basic test. Pass if C<$test> is true, fail if $test is false. Just
-like Test::Simple's C<ok()>.
-
-=cut
-
-sub ok {
- my( $self, $test, $name ) = @_;
-
- if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
- $name = 'unnamed test' unless defined $name;
- $self->is_passing(0);
- $self->croak("Cannot run test ($name) with active children");
- }
- # $test might contain an object which we don't want to accidentally
- # store, so we turn it into a boolean.
- $test = $test ? 1 : 0;
-
- lock $self->{Curr_Test};
- $self->{Curr_Test}++;
-
- # In case $name is a string overloaded object, force it to stringify.
- $self->_unoverload_str( \$name );
-
- $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
- You named your test '$name'. You shouldn't use numbers for your test names.
- Very confusing.
-ERR
-
- # Capture the value of $TODO for the rest of this ok() call
- # so it can more easily be found by other routines.
- my $todo = $self->todo();
- my $in_todo = $self->in_todo;
- local $self->{Todo} = $todo if $in_todo;
-
- $self->_unoverload_str( \$todo );
-
- my $out;
- my $result = &share( {} );
-
- unless($test) {
- $out .= "not ";
- @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
- }
- else {
- @$result{ 'ok', 'actual_ok' } = ( 1, $test );
- }
-
- $out .= "ok";
- $out .= " $self->{Curr_Test}" if $self->use_numbers;
-
- if( defined $name ) {
- $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
- $out .= " - $name";
- $result->{name} = $name;
- }
- else {
- $result->{name} = '';
- }
+ return $file_or_fh if $self->is_fh($file_or_fh);
- if( $self->in_todo ) {
- $out .= " # TODO $todo";
- $result->{reason} = $todo;
- $result->{type} = 'todo';
+ my $fh;
+ if( ref $file_or_fh eq 'SCALAR' ) {
+ open $fh, ">>", $file_or_fh
+ or croak("Can't open scalar ref $file_or_fh: $!");
}
else {
- $result->{reason} = '';
- $result->{type} = '';
- }
-
- $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
- $out .= "\n";
-
- $self->_print($out);
-
- unless($test) {
- my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
- $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
-
- my( undef, $file, $line ) = $self->caller;
- if( defined $name ) {
- $self->diag(qq[ $msg test '$name'\n]);
- $self->diag(qq[ at $file line $line.\n]);
- }
- else {
- $self->diag(qq[ $msg test at $file line $line.\n]);
- }
+ open $fh, ">", $file_or_fh
+ or croak("Can't open test output log $file_or_fh: $!");
+ Test::Stream::IOSets->_autoflush($fh);
}
- $self->is_passing(0) unless $test || $self->in_todo;
-
- # Check that we haven't violated the plan
- $self->_check_is_passing_plan();
-
- return $test ? 1 : 0;
+ return $fh;
}
-
-# Check that we haven't yet violated the plan and set
-# is_passing() accordingly
-sub _check_is_passing_plan {
+sub output {
my $self = shift;
-
- my $plan = $self->has_plan;
- return unless defined $plan; # no plan yet defined
- return unless $plan !~ /\D/; # no numeric plan
- $self->is_passing(0) if $plan < $self->{Curr_Test};
+ my $handles = $self->ctx->stream->io_sets->init_encoding('legacy');
+ $handles->[0] = $self->_new_fh(@_) if @_;
+ return $handles->[0];
}
-
-sub _unoverload {
+sub failure_output {
my $self = shift;
- my $type = shift;
-
- $self->_try(sub { require overload; }, die_on_fail => 1);
-
- foreach my $thing (@_) {
- if( $self->_is_object($$thing) ) {
- if( my $string_meth = overload::Method( $$thing, $type ) ) {
- $$thing = $$thing->$string_meth();
- }
- }
- }
-
- return;
+ my $handles = $self->ctx->stream->io_sets->init_encoding('legacy');
+ $handles->[1] = $self->_new_fh(@_) if @_;
+ return $handles->[1];
}
-sub _is_object {
- my( $self, $thing ) = @_;
-
- return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
-}
-
-sub _unoverload_str {
+sub todo_output {
my $self = shift;
-
- return $self->_unoverload( q[""], @_ );
+ my $handles = $self->ctx->stream->io_sets->init_encoding('legacy');
+ $handles->[2] = $self->_new_fh(@_) if @_;
+ return $handles->[2] || $handles->[0];
}
-sub _unoverload_num {
+sub reset_outputs {
my $self = shift;
-
- $self->_unoverload( '0+', @_ );
-
- for my $val (@_) {
- next unless $self->_is_dualvar($$val);
- $$val = $$val + 0;
- }
-
- return;
-}
-
-# This is a hack to detect a dualvar such as $!
-sub _is_dualvar {
- my( $self, $val ) = @_;
-
- # Objects are not dualvars.
- return 0 if ref $val;
-
- no warnings 'numeric';
- my $numval = $val + 0;
- return ($numval != 0 and $numval ne $val ? 1 : 0);
-}
-
-=item B<is_eq>
-
- $Test->is_eq($got, $expected, $name);
-
-Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
-string version.
-
-C<undef> only ever matches another C<undef>.
-
-=item B<is_num>
-
- $Test->is_num($got, $expected, $name);
-
-Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
-numeric version.
-
-C<undef> only ever matches another C<undef>.
-
-=cut
-
-sub is_eq {
- my( $self, $got, $expect, $name ) = @_;
- local $Level = $Level + 1;
-
- if( !defined $got || !defined $expect ) {
- # undef only matches undef and nothing else
- my $test = !defined $got && !defined $expect;
-
- $self->ok( $test, $name );
- $self->_is_diag( $got, 'eq', $expect ) unless $test;
- return $test;
- }
-
- return $self->cmp_ok( $got, 'eq', $expect, $name );
-}
-
-sub is_num {
- my( $self, $got, $expect, $name ) = @_;
- local $Level = $Level + 1;
-
- if( !defined $got || !defined $expect ) {
- # undef only matches undef and nothing else
- my $test = !defined $got && !defined $expect;
-
- $self->ok( $test, $name );
- $self->_is_diag( $got, '==', $expect ) unless $test;
- return $test;
- }
-
- return $self->cmp_ok( $got, '==', $expect, $name );
+ my $ctx = $self->ctx;
+ $ctx->stream->io_sets->reset_legacy;
}
-sub _diag_fmt {
- my( $self, $type, $val ) = @_;
-
- if( defined $$val ) {
- if( $type eq 'eq' or $type eq 'ne' ) {
- # quote and force string context
- $$val = "'$$val'";
- }
- else {
- # force numeric context
- $self->_unoverload_num($val);
- }
- }
- else {
- $$val = 'undef';
- }
-
- return;
+sub use_numbers {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ $ctx->stream->set_use_numbers(@_) if @_;
+ $ctx->stream->use_numbers;
}
-sub _is_diag {
- my( $self, $got, $type, $expect ) = @_;
-
- $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
-
- local $Level = $Level + 1;
- return $self->diag(<<"DIAGNOSTIC");
- got: $got
- expected: $expect
-DIAGNOSTIC
-
+sub no_ending {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ $ctx->stream->set_no_ending(@_) if @_;
+ $ctx->stream->no_ending || 0;
}
-sub _isnt_diag {
- my( $self, $got, $type ) = @_;
-
- $self->_diag_fmt( $type, \$got );
-
- local $Level = $Level + 1;
- return $self->diag(<<"DIAGNOSTIC");
- got: $got
- expected: anything else
-DIAGNOSTIC
+sub no_header {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ $ctx->stream->set_no_header(@_) if @_;
+ $ctx->stream->no_header || 0;
}
-=item B<isnt_eq>
-
- $Test->isnt_eq($got, $dont_expect, $name);
-
-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 L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is
-the numeric version.
-
-=cut
-
-sub isnt_eq {
- my( $self, $got, $dont_expect, $name ) = @_;
- local $Level = $Level + 1;
-
- if( !defined $got || !defined $dont_expect ) {
- # undef only matches undef and nothing else
- my $test = defined $got || defined $dont_expect;
-
- $self->ok( $test, $name );
- $self->_isnt_diag( $got, 'ne' ) unless $test;
- return $test;
- }
-
- return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
+sub no_diag {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ $ctx->stream->set_no_diag(@_) if @_;
+ $ctx->stream->no_diag || 0;
}
-sub isnt_num {
- my( $self, $got, $dont_expect, $name ) = @_;
- local $Level = $Level + 1;
-
- if( !defined $got || !defined $dont_expect ) {
- # undef only matches undef and nothing else
- my $test = defined $got || defined $dont_expect;
-
- $self->ok( $test, $name );
- $self->_isnt_diag( $got, '!=' ) unless $test;
- return $test;
- }
-
- return $self->cmp_ok( $got, '!=', $dont_expect, $name );
+sub exported_to {
+ my($self, $pack) = @_;
+ $self->{Exported_To} = $pack if defined $pack;
+ return $self->{Exported_To};
}
-=item B<like>
-
- $Test->like($thing, qr/$regex/, $name);
- $Test->like($thing, '/$regex/', $name);
-
-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 L<Test::More>'s C<unlike()>. Checks if $thing B<does not match> the
-given C<$regex>.
-
-=cut
-
-sub like {
- my( $self, $thing, $regex, $name ) = @_;
-
- local $Level = $Level + 1;
- return $self->_regex_ok( $thing, $regex, '=~', $name );
-}
-
-sub unlike {
- my( $self, $thing, $regex, $name ) = @_;
-
- local $Level = $Level + 1;
- return $self->_regex_ok( $thing, $regex, '!~', $name );
-}
-
-=item B<cmp_ok>
-
- $Test->cmp_ok($thing, $type, $that, $name);
-
-Works just like L<Test::More>'s C<cmp_ok()>.
-
- $Test->cmp_ok($big_num, '!=', $other_big_num);
-
-=cut
-
-my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
-
-# Bad, these are not comparison operators. Should we include more?
-my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "...");
-
-sub cmp_ok {
- my( $self, $got, $type, $expect, $name ) = @_;
-
- if ($cmp_ok_bl{$type}) {
- $self->croak("$type is not a valid comparison operator in cmp_ok()");
- }
-
- my $test;
- my $error;
- {
- ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
- local( $@, $!, $SIG{__DIE__} ); # isolate eval
-
- my($pack, $file, $line) = $self->caller();
-
- # This is so that warnings come out at the caller's level
- $test = eval qq[
-#line $line "(eval in cmp_ok) $file"
-\$got $type \$expect;
-];
- $error = $@;
- }
- local $Level = $Level + 1;
- my $ok = $self->ok( $test, $name );
-
- # Treat overloaded objects as numbers if we're asked to do a
- # numeric comparison.
- my $unoverload
- = $numeric_cmps{$type}
- ? '_unoverload_num'
- : '_unoverload_str';
-
- $self->diag(<<"END") if $error;
-An error occurred while using $type:
-------------------------------------
-$error
-------------------------------------
-END
-
- unless($ok) {
- $self->$unoverload( \$got, \$expect );
-
- if( $type =~ /^(eq|==)$/ ) {
- $self->_is_diag( $got, $type, $expect );
- }
- elsif( $type =~ /^(ne|!=)$/ ) {
- $self->_isnt_diag( $got, $type );
- }
- else {
- $self->_cmp_diag( $got, $type, $expect );
- }
- }
- return $ok;
-}
-
-sub _cmp_diag {
- my( $self, $got, $type, $expect ) = @_;
-
- $got = defined $got ? "'$got'" : 'undef';
- $expect = defined $expect ? "'$expect'" : 'undef';
-
- local $Level = $Level + 1;
- return $self->diag(<<"DIAGNOSTIC");
- $got
- $type
- $expect
-DIAGNOSTIC
-}
-
-sub _caller_context {
- my $self = shift;
-
- my( $pack, $file, $line ) = $self->caller(1);
-
- my $code = '';
- $code .= "#line $line $file\n" if defined $file and defined $line;
-
- return $code;
-}
-
-=back
-
-
-=head2 Other Testing Methods
-
-These are methods which are used in the course of writing a test but are not themselves tests.
-
-=over 4
-
-=item B<BAIL_OUT>
-
- $Test->BAIL_OUT($reason);
-
-Indicates to the L<Test::Harness> that things are going so badly all
-testing should terminate. This includes running any additional test
-scripts.
-
-It will exit with 255.
-
-=cut
-
-sub BAIL_OUT {
- my( $self, $reason ) = @_;
-
- $self->{Bailed_Out} = 1;
-
- if ($self->parent) {
- $self->{Bailed_Out_Reason} = $reason;
- $self->no_ending(1);
- die bless {} => 'Test::Builder::Exception';
- }
-
- $self->_print("Bail out! $reason");
- exit 255;
-}
-
-=for deprecated
-BAIL_OUT() used to be BAILOUT()
-
-=cut
-
-{
- no warnings 'once';
- *BAILOUT = \&BAIL_OUT;
-}
-
-=item B<skip>
-
- $Test->skip;
- $Test->skip($why);
-
-Skips the current test, reporting C<$why>.
-
-=cut
-
-sub skip {
- my( $self, $why, $name ) = @_;
- $why ||= '';
- $name = '' unless defined $name;
- $self->_unoverload_str( \$why );
-
- lock( $self->{Curr_Test} );
- $self->{Curr_Test}++;
-
- $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
- {
- 'ok' => 1,
- actual_ok => 1,
- name => $name,
- type => 'skip',
- reason => $why,
- }
- );
-
- my $out = "ok";
- $out .= " $self->{Curr_Test}" if $self->use_numbers;
- $out .= " # skip";
- $out .= " $why" if length $why;
- $out .= "\n";
-
- $self->_print($out);
-
- return 1;
-}
-
-=item B<todo_skip>
-
- $Test->todo_skip;
- $Test->todo_skip($why);
-
-Like C<skip()>, only it will declare the test as failing and TODO. Similar
-to
-
- print "not ok $tnum # TODO $why\n";
-
-=cut
-
-sub todo_skip {
- my( $self, $why ) = @_;
- $why ||= '';
-
- lock( $self->{Curr_Test} );
- $self->{Curr_Test}++;
-
- $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
- {
- 'ok' => 1,
- actual_ok => 0,
- name => '',
- type => 'todo_skip',
- reason => $why,
- }
- );
-
- my $out = "not ok";
- $out .= " $self->{Curr_Test}" if $self->use_numbers;
- $out .= " # TODO & SKIP $why\n";
-
- $self->_print($out);
-
- return 1;
-}
-
-=begin _unimplemented
-
-=item B<skip_rest>
-
- $Test->skip_rest;
- $Test->skip_rest($reason);
-
-Like C<skip()>, only it skips all the rest of the tests you plan to run
-and terminates the test.
-
-If you're running under C<no_plan>, it skips once and terminates the
-test.
-
-=end _unimplemented
-
-=back
-
-
-=head2 Test building utility methods
-
-These methods are useful when writing your own test methods.
-
-=over 4
-
-=item B<maybe_regex>
-
- $Test->maybe_regex(qr/$regex/);
- $Test->maybe_regex('/$regex/');
-
-This method used to be useful back when Test::Builder worked on Perls
-before 5.6 which didn't have qr//. Now its pretty useless.
-
-Convenience method for building testing functions that take regular
-expressions as arguments.
-
-Takes a quoted regular expression produced by C<qr//>, or a string
-representing a regular expression.
-
-Returns a Perl value which may be used instead of the corresponding
-regular expression, or C<undef> if its argument is not recognised.
-
-For example, a version of C<like()>, sans the useful diagnostic messages,
-could be written as:
-
- sub laconic_like {
- my ($self, $thing, $regex, $name) = @_;
- my $usable_regex = $self->maybe_regex($regex);
- die "expecting regex, found '$regex'\n"
- unless $usable_regex;
- $self->ok($thing =~ m/$usable_regex/, $name);
- }
-
-=cut
-
-sub maybe_regex {
- my( $self, $regex ) = @_;
- my $usable_regex = undef;
-
- return $usable_regex unless defined $regex;
-
- my( $re, $opts );
-
- # Check for qr/foo/
- if( _is_qr($regex) ) {
- $usable_regex = $regex;
- }
- # Check for '/foo/' or 'm,foo,'
- elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
- ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
- )
- {
- $usable_regex = length $opts ? "(?$opts)$re" : $re;
- }
-
- return $usable_regex;
-}
-
-sub _is_qr {
- my $regex = shift;
-
- # is_regexp() checks for regexes in a robust manner, say if they're
- # blessed.
- return re::is_regexp($regex) if defined &re::is_regexp;
- return ref $regex eq 'Regexp';
-}
-
-sub _regex_ok {
- my( $self, $thing, $regex, $cmp, $name ) = @_;
-
- my $ok = 0;
- my $usable_regex = $self->maybe_regex($regex);
- unless( defined $usable_regex ) {
- local $Level = $Level + 1;
- $ok = $self->ok( 0, $name );
- $self->diag(" '$regex' doesn't look much like a regex to me.");
- return $ok;
- }
-
- {
- my $test;
- my $context = $self->_caller_context;
-
- {
- ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
- local( $@, $!, $SIG{__DIE__} ); # isolate eval
-
- # No point in issuing an uninit warning, they'll see it in the diagnostics
- no warnings 'uninitialized';
-
- $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0};
- }
-
- $test = !$test if $cmp eq '!~';
-
- local $Level = $Level + 1;
- $ok = $self->ok( $test, $name );
- }
-
- unless($ok) {
- $thing = defined $thing ? "'$thing'" : 'undef';
- my $match = $cmp eq '=~' ? "doesn't match" : "matches";
-
- local $Level = $Level + 1;
- $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex );
- %s
- %13s '%s'
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-# I'm not ready to publish this. It doesn't deal with array return
-# values from the code or context.
-
-=begin private
-
-=item B<_try>
-
- my $return_from_code = $Test->try(sub { code });
- my($return_from_code, $error) = $Test->try(sub { code });
-
-Works like eval BLOCK except it ensures it has no effect on the rest
-of the test (ie. C<$@> is not set) nor is effected by outside
-interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older
-Perls.
-
-C<$error> is what would normally be in C<$@>.
-
-It is suggested you use this in place of eval BLOCK.
-
-=cut
-
-sub _try {
- my( $self, $code, %opts ) = @_;
-
- my $error;
- my $return;
- {
- local $!; # eval can mess up $!
- local $@; # don't set $@ in the test
- local $SIG{__DIE__}; # don't trip an outside DIE handler.
- $return = eval { $code->() };
- $error = $@;
- }
-
- die $error if $error and $opts{die_on_fail};
-
- return wantarray ? ( $return, $error ) : $return;
-}
-
-=end private
-
-
-=item B<is_fh>
-
- my $is_fh = $Test->is_fh($thing);
-
-Determines if the given C<$thing> can be used as a filehandle.
-
-=cut
-
-sub is_fh {
- my $self = shift;
- my $maybe_fh = shift;
- return 0 unless defined $maybe_fh;
+sub is_fh {
+ my $self = shift;
+ my $maybe_fh = shift;
+ return 0 unless defined $maybe_fh;
return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
- return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
-
- return eval { $maybe_fh->isa("IO::Handle") } ||
- eval { tied($maybe_fh)->can('TIEHANDLE') };
-}
-
-=back
-
-
-=head2 Test style
-
-
-=over 4
-
-=item B<level>
-
- $Test->level($how_high);
-
-How far up the call stack should C<$Test> look when reporting where the
-test failed.
-
-Defaults to 1.
-
-Setting L<$Test::Builder::Level> overrides. This is typically useful
-localized:
-
- sub my_ok {
- my $test = shift;
-
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- $TB->ok($test);
- }
-
-To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
-
-=cut
-
-sub level {
- my( $self, $level ) = @_;
-
- if( defined $level ) {
- $Level = $level;
- }
- return $Level;
-}
-
-=item B<use_numbers>
-
- $Test->use_numbers($on_or_off);
-
-Whether or not the test should output numbers. That is, this if true:
-
- ok 1
- ok 2
- ok 3
-
-or this if false
-
- ok
- ok
- ok
-
-Most useful when you can't depend on the test output order, such as
-when threads or forking is involved.
-
-Defaults to on.
-
-=cut
-
-sub use_numbers {
- my( $self, $use_nums ) = @_;
-
- if( defined $use_nums ) {
- $self->{Use_Nums} = $use_nums;
- }
- return $self->{Use_Nums};
-}
-
-=item B<no_diag>
-
- $Test->no_diag($no_diag);
-
-If set true no diagnostics will be printed. This includes calls to
-C<diag()>.
-
-=item B<no_ending>
-
- $Test->no_ending($no_ending);
-
-Normally, Test::Builder does some extra diagnostics when the test
-ends. It also changes the exit code as described below.
-
-If this is true, none of that will be done.
-
-=item B<no_header>
-
- $Test->no_header($no_header);
-
-If set to true, no "1..N" header will be printed.
-
-=cut
-
-foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
- my $method = lc $attribute;
-
- my $code = sub {
- my( $self, $no ) = @_;
-
- if( defined $no ) {
- $self->{$attribute} = $no;
- }
- return $self->{$attribute};
- };
-
- no strict 'refs'; ## no critic
- *{ __PACKAGE__ . '::' . $method } = $code;
-}
-
-=back
-
-=head2 Output
-
-Controlling where the test output goes.
-
-It's ok for your test to change where STDOUT and STDERR point to,
-Test::Builder's default output settings will not be affected.
-
-=over 4
-
-=item B<diag>
-
- $Test->diag(@msgs);
-
-Prints out the given C<@msgs>. Like C<print>, arguments are simply
-appended together.
-
-Normally, it uses the C<failure_output()> handle, but if this is for a
-TODO test, the C<todo_output()> handle is used.
-
-Output will be indented and marked with a # so as not to interfere
-with test output. A newline will be put on the end if there isn't one
-already.
-
-We encourage using this rather than calling print directly.
-
-Returns false. Why? Because C<diag()> is often used in conjunction with
-a failing test (C<ok() || diag()>) it "passes through" the failure.
-
- return ok(...) || diag(...);
-
-=for blame transfer
-Mark Fowler <mark@twoshortplanks.com>
-
-=cut
-
-sub diag {
- my $self = shift;
-
- $self->_print_comment( $self->_diag_fh, @_ );
-}
-
-=item B<note>
-
- $Test->note(@msgs);
-
-Like C<diag()>, but it prints to the C<output()> handle so it will not
-normally be seen by the user except in verbose mode.
-
-=cut
-
-sub note {
- my $self = shift;
-
- $self->_print_comment( $self->output, @_ );
-}
-
-sub _diag_fh {
- my $self = shift;
-
- local $Level = $Level + 1;
- return $self->in_todo ? $self->todo_output : $self->failure_output;
-}
-
-sub _print_comment {
- my( $self, $fh, @msgs ) = @_;
-
- return if $self->no_diag;
- return unless @msgs;
-
- # Prevent printing headers when compiling (i.e. -c)
- return if $^C;
-
- # Smash args together like print does.
- # Convert undef to 'undef' so its readable.
- my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
-
- # Escape the beginning, _print will take care of the rest.
- $msg =~ s/^/# /;
-
- local $Level = $Level + 1;
- $self->_print_to_fh( $fh, $msg );
-
- return 0;
-}
-
-=item B<explain>
-
- my @dump = $Test->explain(@msgs);
-
-Will dump the contents of any references in a human readable format.
-Handy for things like...
-
- is_deeply($have, $want) || diag explain $have;
-
-or
-
- is_deeply($have, $want) || note explain $have;
-
-=cut
-
-sub explain {
- my $self = shift;
-
- return map {
- ref $_
- ? do {
- $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
-
- my $dumper = Data::Dumper->new( [$_] );
- $dumper->Indent(1)->Terse(1);
- $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
- $dumper->Dump;
- }
- : $_
- } @_;
-}
+ return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
-=begin _private
+ my $out;
+ protect {
+ $out = eval { $maybe_fh->isa("IO::Handle") }
+ || eval { tied($maybe_fh)->can('TIEHANDLE') };
+ };
-=item B<_print>
+ return $out;
+}
- $Test->_print(@msgs);
+sub BAILOUT { goto &BAIL_OUT }
-Prints to the C<output()> filehandle.
+sub expected_tests {
+ my $self = shift;
-=end _private
+ my $ctx = $self->ctx;
+ $ctx->plan(@_) if @_;
-=cut
+ my $plan = $ctx->stream->state->[-1]->[STATE_PLAN] || return 0;
+ return $plan->max || 0;
+}
-sub _print {
+sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
my $self = shift;
- return $self->_print_to_fh( $self->output, @_ );
+
+ my $ctx = $self->ctx;
+
+ return wantarray ? $ctx->call : $ctx->package;
}
-sub _print_to_fh {
- my( $self, $fh, @msgs ) = @_;
+sub level {
+ my( $self, $level ) = @_;
+ $Level = $level if defined $level;
+ return $Level;
+}
- # Prevent printing headers when only compiling. Mostly for when
- # tests are deparsed with B::Deparse
- return if $^C;
+sub maybe_regex {
+ my ($self, $regex) = @_;
+ return is_regex($regex);
+}
- my $msg = join '', @msgs;
- my $indent = $self->_indent;
+sub is_passing {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ $ctx->stream->is_passing(@_);
+}
- local( $\, $", $, ) = ( undef, ' ', '' );
+# Yeah, this is not efficient, but it is only legacy support, barely anything
+# uses it, and they really should not.
+sub current_test {
+ my $self = shift;
- # Escape each line after the first with a # so we don't
- # confuse Test::Harness.
- $msg =~ s{\n(?!\z)}{\n$indent# }sg;
+ my $ctx = $self->ctx;
+
+ if (@_) {
+ my ($num) = @_;
+ my $state = $ctx->stream->state->[-1];
+ $state->[STATE_COUNT] = $num;
+
+ my $old = $state->[STATE_LEGACY] || [];
+ my $new = [];
+
+ my $nctx = $ctx->snapshot;
+ $nctx->set_todo('incrementing test number');
+ $nctx->set_in_todo(1);
+
+ for (1 .. $num) {
+ my $i;
+ $i = shift @$old while @$old && (!$i || !$i->isa('Test::Stream::Event::Ok'));
+ $i ||= Test::Stream::Event::Ok->new(
+ $nctx,
+ [CORE::caller()],
+ 0,
+ undef,
+ undef,
+ undef,
+ 1,
+ );
+
+ push @$new => $i;
+ }
- # Stick a newline on the end if it needs it.
- $msg .= "\n" unless $msg =~ /\n\z/;
+ $state->[STATE_LEGACY] = $new;
+ }
- return print $fh $indent, $msg;
+ $ctx->stream->count;
}
-=item B<output>
+sub details {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ my $state = $ctx->stream->state->[-1];
+ my @out;
+ return @out unless $state->[STATE_LEGACY];
-=item B<failure_output>
+ for my $e (@{$state->[STATE_LEGACY]}) {
+ next unless $e && $e->isa('Test::Stream::Event::Ok');
+ push @out => $e->to_legacy;
+ }
-=item B<todo_output>
+ return @out;
+}
- my $filehandle = $Test->output;
- $Test->output($filehandle);
- $Test->output($filename);
- $Test->output(\$scalar);
+sub summary {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ my $state = $ctx->stream->state->[-1];
+ return @{[]} unless $state->[STATE_LEGACY];
+ return map { $_->isa('Test::Stream::Event::Ok') ? ($_->bool ? 1 : 0) : ()} @{$state->[STATE_LEGACY]};
+}
-These methods control where Test::Builder will print its output.
-They take either an open C<$filehandle>, a C<$filename> to open and write to
-or a C<$scalar> reference to append to. It will always return a C<$filehandle>.
+###################################
+# }}} Misc #
+###################################
-B<output> is where normal "ok/not ok" test output goes.
+####################
+# {{{ TB1.5 stuff #
+####################
-Defaults to STDOUT.
+# This is just a list of method Test::Builder current does not have that Test::Builder 1.5 does.
+my %TB15_METHODS = map { $_ => 1 } qw{
+ _file_and_line _join_message _make_default _my_exit _reset_todo_state
+ _result_to_hash _results _todo_state formatter history in_test
+ no_change_exit_code post_event post_result set_formatter set_plan test_end
+ test_exit_code test_start test_state
+};
-B<failure_output> is where diagnostic output on test failures and
-C<diag()> goes. It is normally not read by Test::Harness and instead is
-displayed to the user.
+our $AUTOLOAD;
-Defaults to STDERR.
+sub AUTOLOAD {
+ $AUTOLOAD =~ m/^(.*)::([^:]+)$/;
+ my ($package, $sub) = ($1, $2);
-C<todo_output> is used instead of C<failure_output()> for the
-diagnostics of a failing TODO test. These will not be seen by the
-user.
+ my @caller = CORE::caller();
+ my $msg = qq{Can't locate object method "$sub" via package "$package" at $caller[1] line $caller[2].\n};
-Defaults to STDOUT.
+ $msg .= <<" EOT" if $TB15_METHODS{$sub};
-=cut
+ *************************************************************************
+ '$sub' is a Test::Builder 1.5 method. Test::Builder 1.5 is a dead branch.
+ You need to update your code so that it no longer treats Test::Builders
+ over a specific version number as anything special.
-sub output {
- my( $self, $fh ) = @_;
+ See: http://blogs.perl.org/users/chad_exodist_granum/2014/03/testmore---new-maintainer-also-stop-version-checking.html
+ *************************************************************************
+ EOT
- if( defined $fh ) {
- $self->{Out_FH} = $self->_new_fh($fh);
- }
- return $self->{Out_FH};
+ die $msg;
}
-sub failure_output {
- my( $self, $fh ) = @_;
+####################
+# }}} TB1.5 stuff #
+####################
- if( defined $fh ) {
- $self->{Fail_FH} = $self->_new_fh($fh);
- }
- return $self->{Fail_FH};
-}
+##################################
+# {{{ Legacy support, do not use #
+##################################
-sub todo_output {
- my( $self, $fh ) = @_;
+# These are here to support old versions of Test::More which may be bundled
+# with some dists. See https://github.com/Test-More/test-more/issues/479
- if( defined $fh ) {
- $self->{Todo_FH} = $self->_new_fh($fh);
+sub _try {
+ my( $self, $code, %opts ) = @_;
+
+ my $error;
+ my $return;
+ {
+ local $!; # eval can mess up $!
+ local $@; # don't set $@ in the test
+ local $SIG{__DIE__}; # don't trip an outside DIE handler.
+ $return = eval { $code->() };
+ $error = $@;
}
- return $self->{Todo_FH};
+
+ die $error if $error and $opts{die_on_fail};
+
+ return wantarray ? ( $return, $error ) : $return;
}
-sub _new_fh {
+sub _unoverload {
my $self = shift;
- my($file_or_fh) = shift;
+ my $type = shift;
- my $fh;
- if( $self->is_fh($file_or_fh) ) {
- $fh = $file_or_fh;
- }
- elsif( ref $file_or_fh eq 'SCALAR' ) {
- # Scalar refs as filehandles was added in 5.8.
- if( $] >= 5.008 ) {
- open $fh, ">>", $file_or_fh
- or $self->croak("Can't open scalar ref $file_or_fh: $!");
- }
- # Emulate scalar ref filehandles with a tie.
- else {
- $fh = Test::Builder::IO::Scalar->new($file_or_fh)
- or $self->croak("Can't tie scalar ref $file_or_fh");
+ $self->_try(sub { require overload; }, die_on_fail => 1);
+
+ foreach my $thing (@_) {
+ if( $self->_is_object($$thing) ) {
+ if( my $string_meth = overload::Method( $$thing, $type ) ) {
+ $$thing = $$thing->$string_meth();
+ }
}
}
- else {
- open $fh, ">", $file_or_fh
- or $self->croak("Can't open test output log $file_or_fh: $!");
- _autoflush($fh);
- }
- return $fh;
+ return;
}
-sub _autoflush {
- my($fh) = shift;
- my $old_fh = select $fh;
- $| = 1;
- select $old_fh;
+sub _is_object {
+ my( $self, $thing ) = @_;
- return;
+ return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
}
-my( $Testout, $Testerr );
-
-sub _dup_stdhandles {
+sub _unoverload_str {
my $self = shift;
- $self->_open_testhandles;
-
- # Set everything to unbuffered else plain prints to STDOUT will
- # come out in the wrong order from our own prints.
- _autoflush($Testout);
- _autoflush( \*STDOUT );
- _autoflush($Testerr);
- _autoflush( \*STDERR );
-
- $self->reset_outputs;
-
- return;
+ return $self->_unoverload( q[""], @_ );
}
-sub _open_testhandles {
+sub _unoverload_num {
my $self = shift;
- return if $self->{Opened_Testhandles};
-
- # We dup STDOUT and STDERR so people can change them in their
- # test suites while still getting normal test output.
- open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
- open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
-
- $self->_copy_io_layers( \*STDOUT, $Testout );
- $self->_copy_io_layers( \*STDERR, $Testerr );
+ $self->_unoverload( '0+', @_ );
- $self->{Opened_Testhandles} = 1;
+ for my $val (@_) {
+ next unless $self->_is_dualvar($$val);
+ $$val = $$val + 0;
+ }
return;
}
-sub _copy_io_layers {
- my( $self, $src, $dst ) = @_;
-
- $self->_try(
- sub {
- require PerlIO;
- my @src_layers = PerlIO::get_layers($src);
-
- _apply_layers($dst, @src_layers) if @src_layers;
- }
- );
+# This is a hack to detect a dualvar such as $!
+sub _is_dualvar {
+ my( $self, $val ) = @_;
- return;
-}
+ # Objects are not dualvars.
+ return 0 if ref $val;
-sub _apply_layers {
- my ($fh, @layers) = @_;
- my %seen;
- my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers;
- binmode($fh, join(":", "", "raw", @unique));
+ no warnings 'numeric';
+ my $numval = $val + 0;
+ return ($numval != 0 and $numval ne $val ? 1 : 0);
}
+##################################
+# }}} Legacy support, do not use #
+##################################
-=item reset_outputs
-
- $tb->reset_outputs;
-
-Resets all the output filehandles back to their defaults.
-
-=cut
-
-sub reset_outputs {
- my $self = shift;
-
- $self->output ($Testout);
- $self->failure_output($Testerr);
- $self->todo_output ($Testout);
-
- return;
-}
+1;
-=item carp
+__END__
- $tb->carp(@message);
+=pod
-Warns with C<@message> but the message will appear to come from the
-point where the original test function was called (C<< $tb->caller >>).
+=head1 NAME
-=item croak
+Test::Builder - *DEPRECATED* Module for building testing libraries.
- $tb->croak(@message);
+=head1 DESCRIPTION
-Dies with C<@message> but the message will appear to come from the
-point where the original test function was called (C<< $tb->caller >>).
+This module was previously the base module for almost any testing library. This
+module is now little more than a compatability wrapper around L<Test::Stream>.
+If you are looking to write or update a testing library you should look at
+L<Test::Stream::Toolset>.
-=cut
+=head1 PACKAGE VARS
-sub _message_at_caller {
- my $self = shift;
+=over 4
- local $Level = $Level + 1;
- my( $pack, $file, $line ) = $self->caller;
- return join( "", @_ ) . " at $file line $line.\n";
-}
+=item $Test::Builder::Test
-sub carp {
- my $self = shift;
- return warn $self->_message_at_caller(@_);
-}
+The variable that holds the Test::Builder singleton.
-sub croak {
- my $self = shift;
- return die $self->_message_at_caller(@_);
-}
+=item $Test::Builder::Level
+In the past this variable was used to track stack depth so that Test::Builder
+could report the correct line number. If you use Test::Builder this will still
+work, but in new code it is better to use the L<Test::Stream::Context> module.
=back
+=head1 METHODS
-=head2 Test Status and Info
+=head2 CONSTRUCTORS
=over 4
-=item B<current_test>
+=item Test::Builder->new
- my $curr_test = $Test->current_test;
- $Test->current_test($num);
+Returns the singleton stored in C<$Test::Builder::Test>.
-Gets/sets the current test number we're on. You usually shouldn't
-have to set this.
+=item Test::Builder->create
-If set forward, the details of the missing tests are filled in as 'unknown'.
-if set backward, the details of the intervening tests are deleted. You
-can erase history if you really want to.
+=item Test::Builder->create(use_shared => 1)
-=cut
+Returns a new instance of Test::Builder. It is important to note that this
+instance will not use the shared L<Test::Stream> object unless you pass in the
+C<< use_shared => 1 >> argument.
-sub current_test {
- my( $self, $num ) = @_;
-
- lock( $self->{Curr_Test} );
- if( defined $num ) {
- $self->{Curr_Test} = $num;
-
- # If the test counter is being pushed forward fill in the details.
- my $test_results = $self->{Test_Results};
- if( $num > @$test_results ) {
- my $start = @$test_results ? @$test_results : 0;
- for( $start .. $num - 1 ) {
- $test_results->[$_] = &share(
- {
- 'ok' => 1,
- actual_ok => undef,
- reason => 'incrementing test number',
- type => 'unknown',
- name => undef
- }
- );
- }
- }
- # If backward, wipe history. Its their funeral.
- elsif( $num < @$test_results ) {
- $#{$test_results} = $num - 1;
- }
- }
- return $self->{Curr_Test};
-}
+=back
-=item B<is_passing>
+=head2 UTIL
- my $ok = $builder->is_passing;
+=over 4
-Indicates if the test suite is currently passing.
+=item $TB->ctx
-More formally, it will be false if anything has happened which makes
-it impossible for the test suite to pass. True otherwise.
+Helper method for Test::Builder to get a L<Test::Stream::Context> object.
-For example, if no tests have run C<is_passing()> will be true because
-even though a suite with no tests is a failure you can add a passing
-test to it and start passing.
+=item $TB->depth
-Don't think about it too much.
+Get the subtest depth
-=cut
+=item $TB->find_TODO
-sub is_passing {
- my $self = shift;
+=item $TB->in_todo
- if( @_ ) {
- $self->{Is_Passing} = shift;
- }
+=item $TB->todo
- return $self->{Is_Passing};
-}
+These all check on todo state and value
+=back
-=item B<summary>
+=head2 OTHER
- my @tests = $Test->summary;
+=over 4
-A simple summary of the tests so far. True for pass, false for fail.
-This is a logical pass/fail, so todos are passes.
+=item $TB->caller
-Of course, test #1 is $tests[0], etc...
+=item $TB->carp
-=cut
+=item $TB->croak
-sub summary {
- my($self) = shift;
+These let you figure out when/where the test is defined in the test file.
- return map { $_->{'ok'} } @{ $self->{Test_Results} };
-}
+=item $TB->child
-=item B<details>
+Start a subtest (Please do not use this)
- my @tests = $Test->details;
+=item $TB->finalize
-Like C<summary()>, but with a lot more detail.
+Finish a subtest (Please do not use this)
- $tests[$test_num - 1] =
- { 'ok' => is the test considered a pass?
- actual_ok => did it literally say 'ok'?
- name => name of the test (if any)
- type => type of test (if any, see below).
- reason => reason for the above (if any)
- };
+=item $TB->explain
-'ok' is true if Test::Harness will consider the test to be a pass.
+Interface to Data::Dumper that dumps whatever you give it.
-'actual_ok' is a reflection of whether or not the test literally
-printed 'ok' or 'not ok'. This is for examining the result of 'todo'
-tests.
+=item $TB->exported_to
-'name' is the name of the test.
+This used to tell you what package used Test::Builder, it never worked well.
+The previous bad and unpredictable behavior of this has largely been preserved,
+however nothing internal uses it in any meaningful way anymore.
-'type' indicates if it was a special test. Normal tests have a type
-of ''. Type can be one of the following:
+=item $TB->is_fh
- skip see skip()
- todo see todo()
- todo_skip see todo_skip()
- unknown see below
+Check if something is a filehandle
-Sometimes the Test::Builder test counter is incremented without it
-printing any test output, for example, when C<current_test()> is changed.
-In these cases, Test::Builder doesn't know the result of the test, so
-its type is 'unknown'. These details for these tests are filled in.
-They are considered ok, but the name and actual_ok is left C<undef>.
+=item $TB->level
-For example "not ok 23 - hole count # TODO insufficient donuts" would
-result in this structure:
+Get/Set C<$Test::Builder::Level>. $Level is a package var, and most thigns
+localize it, so this method is pretty useless.
- $tests[22] = # 23 - 1, since arrays start from 0.
- { ok => 1, # logically, the test passed since its todo
- actual_ok => 0, # in absolute terms, it failed
- name => 'hole count',
- type => 'todo',
- reason => 'insufficient donuts'
- };
+=item $TB->maybe_regex
-=cut
+Check if something might be a regex.
-sub details {
- my $self = shift;
- return @{ $self->{Test_Results} };
-}
+=item $TB->reset
-=item B<todo>
+Reset the builder object to a very basic and default state. You almost
+certainly do not need this unless you are writing a tool to test testing
+libraries. Even then you probably do not want this.
- my $todo_reason = $Test->todo;
- my $todo_reason = $Test->todo($pack);
+=item $TB->todo_end
-If the current tests are considered "TODO" it will return the reason,
-if any. This reason can come from a C<$TODO> variable or the last call
-to C<todo_start()>.
+=item $TB->todo_start
-Since a TODO test does not need a reason, this function can return an
-empty string even when inside a TODO block. Use C<< $Test->in_todo >>
-to determine if you are currently inside a TODO block.
+Start/end TODO state, there are better ways to do this now.
-C<todo()> is about finding the right package to look for C<$TODO> in. It's
-pretty good at guessing the right package to look at. It first looks for
-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()>.
+=back
-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.
+=head2 STREAM INTERFACE
-=cut
+These simply interface into functionality of L<Test::Stream>.
-sub todo {
- my( $self, $pack ) = @_;
+=over 4
- return $self->{Todo} if defined $self->{Todo};
+=item $TB->failure_output
- local $Level = $Level + 1;
- my $todo = $self->find_TODO($pack);
- return $todo if defined $todo;
+=item $TB->output
- return '';
-}
+=item $TB->reset_outputs
-=item B<find_TODO>
+=item $TB->todo_output
- my $todo_reason = $Test->find_TODO();
- my $todo_reason = $Test->find_TODO($pack);
+These get/set the IO handle used in the 'legacy' tap encoding.
-Like C<todo()> but only returns the value of C<$TODO> ignoring
-C<todo_start()>.
+=item $TB->no_diag
-Can also be used to set C<$TODO> to a new value while returning the
-old value:
+Do not display L<Test::Stream::Event::Diag> events.
- my $old_reason = $Test->find_TODO($pack, 1, $new_reason);
+=item $TB->no_ending
-=cut
+Do not do some special magic at the end that tells you what went wrong with
+tests.
-sub find_TODO {
- my( $self, $pack, $set, $new_value ) = @_;
+=item $TB->no_header
- $pack = $pack || $self->caller(1) || $self->exported_to;
- return unless $pack;
+Do not display the plan
- no strict 'refs'; ## no critic
- my $old_value = ${ $pack . '::TODO' };
- $set and ${ $pack . '::TODO' } = $new_value;
- return $old_value;
-}
+=item $TB->use_numbers
-=item B<in_todo>
+Turn numbers in TAP on and off.
- my $in_todo = $Test->in_todo;
+=back
-Returns true if the test is currently inside a TODO block.
+=head2 HISTORY
-=cut
+=over
-sub in_todo {
- my $self = shift;
+=item $TB->details
- local $Level = $Level + 1;
- return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
-}
+Get all the events that occured on this object. Each event will be transformed
+into a hash that matches the legacy output of this method.
-=item B<todo_start>
+=item $TB->expected_tests
- $Test->todo_start();
- $Test->todo_start($message);
+Set/Get expected number of tests
-This method allows you declare all subsequent tests as TODO tests, up until
-the C<todo_end> method has been called.
+=item $TB->has_plan
-The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
-whether or not we're in a TODO test. However, often we find that this is not
-possible to determine (such as when we want to use C<$TODO> but
-the tests are being executed in other packages which can't be inferred
-beforehand).
+Check if there is a plan
-Note that you can use this to nest "todo" tests
+=item $TB->summary
- $Test->todo_start('working on this');
- # lots of code
- $Test->todo_start('working on that');
- # more code
- $Test->todo_end;
- $Test->todo_end;
+List of pass/fail results.
-This is generally not recommended, but large testing systems often have weird
-internal needs.
+=back
-We've tried to make this also work with the TODO: syntax, but it's not
-guaranteed and its use is also discouraged:
+=head2 EVENT GENERATORS
- TODO: {
- local $TODO = 'We have work to do!';
- $Test->todo_start('working on this');
- # lots of code
- $Test->todo_start('working on that');
- # more code
- $Test->todo_end;
- $Test->todo_end;
- }
+See L<Test::Stream::Context>, L<Test::Stream::Toolset>, and
+L<Test::More::Tools>. Calling the methods below is not advised.
-Pick one style or another of "TODO" to be on the safe side.
+=over 4
-=cut
+=item $TB->BAILOUT
-sub todo_start {
- my $self = shift;
- my $message = @_ ? shift : '';
+=item $TB->BAIL_OUT
- $self->{Start_Todo}++;
- if( $self->in_todo ) {
- push @{ $self->{Todo_Stack} } => $self->todo;
- }
- $self->{Todo} = $message;
+=item $TB->cmp_ok
- return;
-}
+=item $TB->current_test
-=item C<todo_end>
+=item $TB->diag
- $Test->todo_end;
+=item $TB->done_testing
-Stops running tests as "TODO" tests. This method is fatal if called without a
-preceding C<todo_start> method call.
+=item $TB->is_eq
-=cut
+=item $TB->is_num
-sub todo_end {
- my $self = shift;
+=item $TB->is_passing
- if( !$self->{Start_Todo} ) {
- $self->croak('todo_end() called without todo_start()');
- }
+=item $TB->isnt_eq
- $self->{Start_Todo}--;
+=item $TB->isnt_num
- if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
- $self->{Todo} = pop @{ $self->{Todo_Stack} };
- }
- else {
- delete $self->{Todo};
- }
+=item $TB->like
- return;
-}
+=item $TB->no_plan
-=item B<caller>
+=item $TB->note
- my $package = $Test->caller;
- my($pack, $file, $line) = $Test->caller;
- my($pack, $file, $line) = $Test->caller($height);
+=item $TB->ok
-Like the normal C<caller()>, except it reports according to your C<level()>.
+=item $TB->plan
-C<$height> will be added to the C<level()>.
+=item $TB->skip
-If C<caller()> winds up off the top of the stack it report the highest context.
+=item $TB->skip_all
-=cut
+=item $TB->subtest
-sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
- my( $self, $height ) = @_;
- $height ||= 0;
+=item $TB->todo_skip
- my $level = $self->level + $height + 1;
- my @caller;
- do {
- @caller = CORE::caller( $level );
- $level--;
- } until @caller;
- return wantarray ? @caller : $caller[0];
-}
+=item $TB->unlike
=back
-=cut
-
-=begin _private
+=head2 ACCESSORS
=over 4
-=item B<_sanity_check>
+=item $TB->stream
- $self->_sanity_check();
+Get the stream used by this builder (or the shared stream).
-Runs a bunch of end of test sanity checks to make sure reality came
-through ok. If anything is wrong it will die with a fairly friendly
-error message.
+=item $TB->name
-=cut
+Name of the test
-#'#
-sub _sanity_check {
- my $self = shift;
-
- $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
- $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
- 'Somehow you got a different number of results than tests ran!' );
+=item $TB->parent
- return;
-}
+Parent if this is a child.
-=item B<_whoa>
+=back
- $self->_whoa($check, $description);
+=head1 MONKEYPATCHING
-A sanity check, similar to C<assert()>. If the C<$check> is true, something
-has gone horribly wrong. It will die with the given C<$description> and
-a note to contact the author.
+Many legacy testing modules monkeypatch C<ok()>, C<plan()>, and others. The
+abillity to monkeypatch these to effect all events of the specified type is now
+considered discouraged. For backwords compatability monkeypatching continues to
+work, however in the distant future it will be removed. L<Test::Stream> upon
+which Test::Builder is now built, provides hooks and API's for doing everything
+that previously required monkeypatching.
-=cut
+=encoding utf8
-sub _whoa {
- my( $self, $check, $desc ) = @_;
- if($check) {
- local $Level = $Level + 1;
- $self->croak(<<"WHOA");
-WHOA! $desc
-This should never happen! Please contact the author immediately!
-WHOA
- }
+=head1 TUTORIALS
- return;
-}
+=over 4
-=item B<_my_exit>
+=item L<Test::Tutorial>
- _my_exit($exit_num);
+The original L<Test::Tutorial>. Uses comedy to introduce you to testing from
+scratch.
-Perl seems to have some trouble with exiting inside an C<END> block.
-5.6.1 does some odd things. Instead, this function edits C<$?>
-directly. It should B<only> be called from inside an C<END> block.
-It doesn't actually exit, that's your job.
+=item L<Test::Tutorial::WritingTests>
-=cut
+The L<Test::Tutorial::WritingTests> tutorial takes a more technical approach.
+The idea behind this tutorial is to give you a technical introduction to
+testing that can easily be used as a reference. This is for people who say
+"Just tell me how to do it, and quickly!".
-sub _my_exit {
- $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
+=item L<Test::Tutorial::WritingTools>
- return 1;
-}
+The L<Test::Tutorial::WritingTools> tutorial is an introduction to writing
+testing tools that play nicely with other L<Test::Stream> and L<Test::Builder>
+based tools. This is what you should look at if you want to write
+Test::MyWidget.
=back
-=end _private
-
-=cut
-
-sub _ending {
- my $self = shift;
- return if $self->no_ending;
- return if $self->{Ending}++;
-
- my $real_exit_code = $?;
+=head1 SOURCE
- # Don't bother with an ending if this is a forked copy. Only the parent
- # should do the ending.
- if( $self->{Original_Pid} != $$ ) {
- return;
- }
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
- # Ran tests but never declared a plan or hit done_testing
- if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
- $self->is_passing(0);
- $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
-
- if($real_exit_code) {
- $self->diag(<<"FAIL");
-Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
-FAIL
- $self->is_passing(0);
- _my_exit($real_exit_code) && return;
- }
+=head1 MAINTAINER
- # But if the tests ran, handle exit code.
- my $test_results = $self->{Test_Results};
- if(@$test_results) {
- my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
- if ($num_failed > 0) {
+=over 4
- my $exit_code = $num_failed <= 254 ? $num_failed : 254;
- _my_exit($exit_code) && return;
- }
- }
- _my_exit(254) && return;
- }
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
- # Exit if plan() was never called. This is so "require Test::Simple"
- # doesn't puke.
- if( !$self->{Have_Plan} ) {
- return;
- }
+=back
- # Don't do an ending if we bailed out.
- if( $self->{Bailed_Out} ) {
- $self->is_passing(0);
- return;
- }
- # Figure out if we passed or failed and print helpful messages.
- my $test_results = $self->{Test_Results};
- if(@$test_results) {
- # The plan? We have no plan.
- if( $self->{No_Plan} ) {
- $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
- $self->{Expected_Tests} = $self->{Curr_Test};
- }
+=head1 AUTHORS
- # Auto-extended arrays and elements which aren't explicitly
- # filled in with a shared reference will puke under 5.8.0
- # ithreads. So we have to fill them in by hand. :(
- my $empty_result = &share( {} );
- for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
- $test_results->[$idx] = $empty_result
- unless defined $test_results->[$idx];
- }
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
- my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
+=over 4
- my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
- if( $num_extra != 0 ) {
- my $s = $self->{Expected_Tests} == 1 ? '' : 's';
- $self->diag(<<"FAIL");
-Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
-FAIL
- $self->is_passing(0);
- }
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
- if($num_failed) {
- my $num_tests = $self->{Curr_Test};
- my $s = $num_failed == 1 ? '' : 's';
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
- my $qualifier = $num_extra == 0 ? '' : ' run';
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
- $self->diag(<<"FAIL");
-Looks like you failed $num_failed test$s of $num_tests$qualifier.
-FAIL
- $self->is_passing(0);
- }
+=item 唐鳳
- if($real_exit_code) {
- $self->diag(<<"FAIL");
-Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
-FAIL
- $self->is_passing(0);
- _my_exit($real_exit_code) && return;
- }
+=back
- my $exit_code;
- if($num_failed) {
- $exit_code = $num_failed <= 254 ? $num_failed : 254;
- }
- elsif( $num_extra != 0 ) {
- $exit_code = 255;
- }
- else {
- $exit_code = 0;
- }
+=head1 COPYRIGHT
- _my_exit($exit_code) && return;
- }
- elsif( $self->{Skip_All} ) {
- _my_exit(0) && return;
- }
- elsif($real_exit_code) {
- $self->diag(<<"FAIL");
-Looks like your test exited with $real_exit_code before it could output anything.
-FAIL
- $self->is_passing(0);
- _my_exit($real_exit_code) && return;
- }
- else {
- $self->diag("No tests run!\n");
- $self->is_passing(0);
- _my_exit(255) && return;
- }
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
- $self->is_passing(0);
- $self->_whoa( 1, "We fell off the end of _ending()" );
-}
+=over 4
-END {
- $Test->_ending if defined $Test;
-}
+=item Test::Stream
-=head1 EXIT CODES
+=item Test::Stream::Tester
-If all your tests passed, 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 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.
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
-So the exit codes are...
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
- 0 all tests successful
- 255 test died or all passed but wrong # of tests run
- any other number how many failed (including missing or extras)
+See F<http://www.perl.com/perl/misc/Artistic.html>
-If you fail more than 254 tests, it will be reported as 254.
+=item Test::Simple
-=head1 THREADS
+=item Test::More
-In perl 5.8.1 and later, Test::Builder is thread-safe. The test
-number is shared amongst all threads. This means if one thread sets
-the test number using C<current_test()> they will all be effected.
+=item Test::Builder
-While versions earlier than 5.8.1 had threads they contain too many
-bugs to support.
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
-Test::Builder is only thread-aware if threads.pm is loaded I<before>
-Test::Builder.
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
-=head1 MEMORY
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
-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)
-combinatorics tests in the same run.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
-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 C<fail()> should anything go unexpected.
+See F<http://www.perl.com/perl/misc/Artistic.html>
-Future versions of Test::Builder will have a way to turn history off.
+=item Test::use::ok
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
-=head1 EXAMPLES
+This work is published from Taiwan.
-CPAN can provide the best examples. L<Test::Simple>, L<Test::More>,
-L<Test::Exception> and L<Test::Differences> all use Test::Builder.
+L<http://creativecommons.org/publicdomain/zero/1.0>
-=head1 SEE ALSO
+=item Test::Tester
-L<Test::Simple>, L<Test::More>, L<Test::Harness>
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
-=head1 AUTHORS
+Under the same license as Perl itself
-Original code by chromatic, maintained by Michael G Schwern
-E<lt>schwern@pobox.comE<gt>
+See http://www.perl.com/perl/misc/Artistic.html
-=head1 MAINTAINERS
+=item Test::Builder::Tester
-=over 4
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
-=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
=back
-
-=head1 COPYRIGHT
-
-Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
- Michael G Schwern E<lt>schwern@pobox.comE<gt>.
-
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-See F<http://www.perl.com/perl/misc/Artistic.html>
-
-=cut
-
-1;
-
use strict;
+use Test::Stream 1.301001 '-internal';
use Test::Builder 0.99;
require Exporter;
our @ISA = qw(Exporter);
-our $VERSION = '1.001008';
+our $VERSION = '1.301001_075';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
=head1 NAME
-Test::Builder::Module - Base class for test modules
+Test::Builder::Module - *DEPRECATED* Base class for test modules
+
+=head1 DEPRECATED
+
+B<This module is deprecated> See L<Test::Stream::Toolset> for what you should
+use instead.
=head1 SYNOPSIS
my $tb = $CLASS->builder;
return $tb->ok(@_);
}
-
+
1;
=head1 DESCRIPTION
+B<This module is deprecated> See L<Test::Stream::Toolset> for what you should
+use instead.
+
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
L<Test::Builder> object.
exporting of functions and variables. This allows your module to set
the plan independent of L<Test::More>.
-All arguments passed to C<import()> are passed onto
-C<< Your::Module->builder->plan() >> with the exception of
+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;
sub import {
my($class) = shift;
+ my $test = $class->builder;
+ my $caller = caller;
+
+ warn __PACKAGE__ . " is deprecated!\n" if $caller->can('TB_INSTANCE') && $caller->TB_INSTANCE->modern;
+
# Don't run all this when loading ourself.
return 1 if $class eq 'Test::Builder::Module';
- my $test = $class->builder;
-
- my $caller = caller;
$test->exported_to($caller);
}
1;
+
+__END__
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
package Test::Builder::Tester;
use strict;
-our $VERSION = "1.24";
+our $VERSION = '1.301001_075';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-use Test::Builder 0.98;
+use Test::Stream 1.301001 '-internal';
+use Test::Builder 1.301001;
use Symbol;
-use Carp;
+use Test::Stream::Carp qw/croak/;
=head1 NAME
-Test::Builder::Tester - test testsuites that have been built with
+Test::Builder::Tester - *DEPRECATED* test testsuites that have been built with
Test::Builder
+=head1 DEPRECATED
+
+B<This module is deprecated.> Please see L<Test::Stream::Tester> for a
+better alternative that does not involve dealing with TAP/string output.
+
=head1 SYNOPSIS
use Test::Builder::Tester tests => 1;
# set up testing
####
-my $t = Test::Builder->new;
+#my $t = Test::Builder->new;
###
# make us an exporter
###
-use Exporter;
-our @ISA = qw(Exporter);
-
-our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);
+use Test::Stream::Toolset;
+use Test::Stream::Exporter;
+default_exports qw/test_out test_err test_fail test_diag test_test line_num/;
+Test::Stream::Exporter->cleanup;
-sub import {
+sub before_import {
my $class = shift;
- my(@plan) = @_;
+ my ($importer, $list) = @_;
- my $caller = caller;
+ my $meta = init_tester($importer);
+ my $context = context(1);
+ my $other = [];
+ my $idx = 0;
- $t->exported_to($caller);
- $t->plan(@plan);
+ while ($idx <= $#{$list}) {
+ my $item = $list->[$idx++];
+ next unless $item;
- my @imports = ();
- foreach my $idx ( 0 .. $#plan ) {
- if( $plan[$idx] eq 'import' ) {
- @imports = @{ $plan[ $idx + 1 ] };
- last;
+ if (defined $item and $item eq 'no_diag') {
+ Test::Stream->shared->set_no_diag(1);
+ }
+ elsif ($item eq 'tests') {
+ $context->plan($list->[$idx++]);
+ }
+ elsif ($item eq 'skip_all') {
+ $context->plan(0, 'SKIP', $list->[$idx++]);
+ }
+ elsif ($item eq 'no_plan') {
+ $context->plan(0, 'NO PLAN');
+ }
+ elsif ($item eq 'import') {
+ push @$other => @{$list->[$idx++]};
}
}
- __PACKAGE__->export_to_level( 1, __PACKAGE__, @imports );
+ @$list = @$other;
+
+ return;
}
+
+sub builder { Test::Builder->new }
+
###
# set up file handles
###
my $testing_num;
my $original_is_passing;
+my $original_stream;
+my $original_state;
+
# remembering where the file handles were originally connected
my $original_output_handle;
my $original_failure_handle;
$original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
$ENV{HARNESS_ACTIVE} = 0;
+ $original_stream = builder->{stream} || Test::Stream->shared;
+ $original_state = [@{$original_stream->state->[-1]}];
+
# remember what the handles were set to
- $original_output_handle = $t->output();
- $original_failure_handle = $t->failure_output();
- $original_todo_handle = $t->todo_output();
+ $original_output_handle = builder()->output();
+ $original_failure_handle = builder()->failure_output();
+ $original_todo_handle = builder()->todo_output();
# switch out to our own handles
- $t->output($output_handle);
- $t->failure_output($error_handle);
- $t->todo_output($output_handle);
+ builder()->output($output_handle);
+ builder()->failure_output($error_handle);
+ builder()->todo_output($output_handle);
# clear the expected list
$out->reset();
# remember that we're testing
$testing = 1;
- $testing_num = $t->current_test;
- $t->current_test(0);
- $original_is_passing = $t->is_passing;
- $t->is_passing(1);
+ $testing_num = builder()->current_test;
+ builder()->current_test(0);
+ $original_is_passing = builder()->is_passing;
+ builder()->is_passing(1);
# look, we shouldn't do the ending stuff
- $t->no_ending(1);
+ builder()->no_ending(1);
}
=head2 Functions
=cut
sub test_out {
+ my $ctx = context;
# do we need to do any setup?
_start_testing() unless $testing;
}
sub test_err {
+ my $ctx = context;
# do we need to do any setup?
_start_testing() unless $testing;
=cut
sub test_fail {
+ my $ctx = context;
# do we need to do any setup?
_start_testing() unless $testing;
=cut
sub test_diag {
+ my $ctx = context;
# do we need to do any setup?
_start_testing() unless $testing;
# expect the same thing, but prepended with "# "
local $_;
- $err->expect( map { "# $_" } @_ );
+ $err->expect( map { m/\S/ ? "# $_" : "" } @_ );
}
=item test_test
=cut
sub test_test {
+ my $ctx = context;
# decode the arguments as described in the pod
my $mess;
my %args;
unless $testing;
# okay, reconnect the test suite back to the saved handles
- $t->output($original_output_handle);
- $t->failure_output($original_failure_handle);
- $t->todo_output($original_todo_handle);
+ builder()->output($original_output_handle);
+ builder()->failure_output($original_failure_handle);
+ builder()->todo_output($original_todo_handle);
# restore the test no, etc, back to the original point
- $t->current_test($testing_num);
+ builder()->current_test($testing_num);
$testing = 0;
- $t->is_passing($original_is_passing);
+ builder()->is_passing($original_is_passing);
# re-enable the original setting of the harness
$ENV{HARNESS_ACTIVE} = $original_harness_env;
+ $original_stream->state->[-1] = $original_state;
+
# check the output we've stashed
- unless( $t->ok( ( $args{skip_out} || $out->check ) &&
- ( $args{skip_err} || $err->check ), $mess )
+ unless( builder()->ok( ( $args{skip_out} || $out->check ) &&
+ ( $args{skip_err} || $err->check ), $mess )
)
{
# print out the diagnostic information about why this
local $_;
- $t->diag( map { "$_\n" } $out->complaint )
+ builder()->diag( map { "$_\n" } $out->complaint )
unless $args{skip_out} || $out->check;
- $t->diag( map { "$_\n" } $err->complaint )
+ builder()->diag( map { "$_\n" } $err->complaint )
unless $args{skip_err} || $err->check;
}
}
=back
-=head1 BUGS
+=head1 NOTES
-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.
+Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
+me use his testing system to try this module out on.
-The color function doesn't work unless L<Term::ANSIColor> is
-compatible with your terminal.
+=head1 SEE ALSO
-Bugs (and requests for new features) can be reported to the author
-though the CPAN RT system:
-L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester>
+L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
-=head1 AUTHOR
+=encoding utf8
-Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+=head1 SOURCE
-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.
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
-This program is free software; you can redistribute it
-and/or modify it under the same terms as Perl itself.
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
-=head1 MAINTAINERS
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
=back
-=head1 NOTES
+=head1 COPYRIGHT
-Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
-me use his testing system to try this module out on.
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
-=head1 SEE ALSO
+=over 4
-L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
=cut
sub _account_for_subtest {
my( $self, $check ) = @_;
+ my $ctx = Test::Stream::Context::context();
+ my $depth = @{$ctx->stream->subtests};
# Since we ship with Test::Builder, calling a private method is safe...ish.
- return ref($check) ? $check : $t->_indent . $check;
+ return ref($check) ? $check : ($depth ? ' ' x $depth : '') . $check;
}
sub _translate_Failed_check {
package Test::Builder::Tester::Color;
use strict;
-our $VERSION = "1.24";
+our $VERSION = '1.301001_075';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+use Test::Stream 1.301001 '-internal';
require Test::Builder::Tester;
=cut
1;
+
+__END__
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+=head1 NAME
+
+Test::FAQ - Frequently Asked Questions about testing with Perl
+
+=head1 DESCRIPTION
+
+Frequently Asked Questions about testing in general and specific
+issues with Perl.
+
+=head2 Is there any tutorial on testing?
+
+L<Test::Tutorial>
+
+=head2 Are there any modules for testing?
+
+A whole bunch. Start with L<Test::Simple> then move onto Test::More.
+
+Then go onto L<http://search.cpan.org> and search for "Test".
+
+Also check out L<Fennec>.
+
+=head2 Are there any modules for testing web pages/CGI programs?
+
+L<Test::WWW::Mechanize>, L<Test::WWW::Selenium>
+
+=head2 Are there any modules for testing external programs?
+
+L<Test::Cmd>
+
+=head2 Can you do xUnit/JUnit style testing in Perl?
+
+Yes, L<Test::Class> allows you to write test methods while continuing to
+use all the usual CPAN testing modules. It is the best and most
+perlish way to do xUnit style testing.
+
+L<Test::Unit> is a more direct port of XUnit to Perl, but it does not use
+the Perl conventions and does not play well with other CPAN testing
+modules. As of this writing, it is abandoned. B<Do not use>.
+
+The L<Test::Inline> (aka L<Pod::Tests>) is worth mentioning as it allows you to
+put tests into the POD in the same file as the code.
+
+
+=head2 How do I test my module is backwards/forwards compatible?
+
+First, install a bunch of perls of commonly used versions. At the
+moment, you could try these
+
+ 5.7.2
+ 5.6.1
+ 5.005_03
+ 5.004_05
+
+if you're feeling brave, you might want to have on hand these
+
+ bleadperl
+ 5.6.0
+ 5.004_04
+ 5.004
+
+going back beyond 5.003 is probably beyond the call of duty.
+
+You can then add something like this to your F<Makefile.PL>. It
+overrides the L<ExtUtils::MakeMaker> C<test_via_harness()> method to run the tests
+against several different versions of Perl.
+
+ # If PERL_TEST_ALL is set, run "make test" against
+ # other perls as well as the current perl.
+ {
+ package MY;
+
+ sub test_via_harness {
+ my($self, $orig_perl, $tests) = @_;
+
+ # names of your other perl binaries.
+ my @other_perls = qw(perl5.004_05 perl5.005_03 perl5.7.2);
+
+ my @perls = ($orig_perl);
+ push @perls, @other_perls if $ENV{PERL_TEST_ALL};
+
+ my $out;
+ foreach my $perl (@perls) {
+ $out .= $self->SUPER::test_via_harness($perl, $tests);
+ }
+
+ return $out;
+ }
+ }
+
+and re-run your F<Makefile.PL> with the C<PERL_TEST_ALL> environment
+variable set
+
+ PERL_TEST_ALL=1 perl Makefile.PL
+
+now C<make test> will run against each of your other perls.
+
+
+=head2 If I'm testing Foo::Bar, where do I put tests for Foo::Bar::Baz?
+
+=head2 How do I know when my tests are good enough?
+
+A: Use tools for measuring the code coverage of your tests, e.g. how many of
+your source code lines/subs/expressions/paths are executed (aka covered) by
+the test suite. The more, the better, of course, although you may not
+be able achieve 100%. If your testsuite covers under 100%, then
+the rest of your code is, basically, untested. Which means it may work in
+surprising ways (e.g. doesn't do things like they are intended or
+documented), have bugs (e.g. return wrong results) or it may not work at
+all.
+
+=head2 How do I measure the coverage of my test suite?
+
+L<Devel::Cover>
+
+=head2 How do I get tests to run in a certain order?
+
+Tests run in alphabetical order, so simply name your test files in the order
+you want them to run. Numbering your test files works, too.
+
+ t/00_compile.t
+ t/01_config.t
+ t/zz_teardown.t
+
+0 runs first, z runs last.
+
+To achieve a specific order, try L<Test::Manifest>.
+
+Typically you do B<not> want your tests to require being run in a
+certain order, but it can be useful to do a compile check first or to
+run the tests on a very basic module before everything else. This
+gives you early information if a basic module fails which will bring
+everything else down.
+
+Another use is if you have a suite wide setup/teardown, such as
+creating and delete a large test database, which may be too
+expensive to do for every test.
+
+We recommend B<against> numbering every test file. For most files
+this ordering will be arbitrary and the leading number obscures the
+real name of the file. See L<What should I name my test files?> for
+more information.
+
+
+=head2 What should I name my tests?
+
+=head2 What should I name my test files?
+
+A test filename serves three purposes:
+
+Most importantly, it serves to identify what is being tested. Each
+test file should test a clear piece of functionality. This could be
+at single class, a single method, even a single bug.
+
+The order in which tests are run is usually dictated by the filename.
+See L<How do I get tests to run in a certain order?> for details.
+
+Finally, the grouping of tests into common bits of functionality can
+be achieved by directory and filenames. For example, all the tests
+for L<Test::Builder> are in the F<t/Builder/> directory.
+
+As an example, F<t/Builder/reset.t> contains the tests for
+C<< Test::Builder->reset >>. F<t/00compile.t> checks that everything
+compiles, and it will run first. F<t/dont_overwrite_die_handler.t>
+checks that we don't overwrite the C<< $SIG{__DIE__} >> handler.
+
+
+=head2 How do I deal with tests that sometimes pass and sometimes fail?
+
+=head2 How do I test with a database/network/server that the user may or may not have?
+
+=head2 What's a good way to test lists?
+
+C<is_deeply()> from L<Test::More> as well as L<Test::Deep>.
+
+=head2 Is there such a thing as untestable code?
+
+There's always compile/export checks.
+
+Code must be written with testability in mind. Separation of form and
+functionality.
+
+=head2 What do I do when I can't make the code do the same thing twice?
+
+Force it to do the same thing twice.
+
+Even a random number generator can be tested.
+
+=head2 How do I test a GUI?
+
+=head2 How do I test an image generator?
+
+=head2 How do I test that my code handles failures gracefully?
+
+=head2 How do I check the right warnings are issued?
+
+L<Test::Warn>
+
+=head2 How do I test code that prints?
+
+L<Test::Output>
+
+=head2 I want to test that my code dies when I do X
+
+L<Test::Exception>
+
+=head2 I want to print out more diagnostic info on failure.
+
+C<ok(...) || diag "...";>
+
+=head2 How can I simulate failures to make sure that my code does the Right Thing in the face of them?
+
+
+=head2 Why use an ok() function?
+
+On Tue, Aug 28, 2001 at 02:12:46PM +0100, Robin Houston wrote:
+> Michael Schwern wrote:
+> > Ah HA! I've been wondering why nobody ever thinks to write a simple
+> > ok() function for their tests! perlhack has bad testing advice.
+>
+> Could you explain the advantage of having a "simple ok() function"?
+
+Because writing:
+
+ print "not " unless some thing worked;
+ print "ok $test\n"; $test++;
+
+gets rapidly annoying. This is why we made up subroutines in the
+first place. It also looks like hell and obscures the real purpose.
+
+Besides, that will cause problems on VMS.
+
+
+> As somebody who has spent many painful hours debugging test failures,
+> I'm intimately familiar with the _disadvantages_. When you run the
+> test, you know that "test 113 failed". That's all you know, in general.
+
+Second advantage is you can easily upgrade the C<ok()> function to fix
+this, either by slapping this line in:
+
+ printf "# Failed test at line %d\n", (caller)[2];
+
+or simply junking the whole thing and switching to L<Test::Simple> or
+L<Test::More>, which does all sorts of nice diagnostics-on-failure for
+you. Its C<ok()> function is backwards compatible with the above.
+
+There's some issues with using L<Test::Simple> to test really basic Perl
+functionality, you have to choose on a per test basis. Since
+L<Test::Simple> doesn't use C<pack()> it's safe for F<t/op/pack.t> to use
+L<Test::Simple>. I just didn't want to make the perlhack patching
+example too complicated.
+
+
+=head2 Dummy Mode
+
+> One compromise would be to use a test-generating script, which allows
+> the tests to be structured simply and _generates_ the actual test
+> code. One could then grep the generated test script to locate the
+> failing code.
+
+This is a very interesting, and very common, response to the problem.
+I'm going to make some observations about reactions to testing,
+they're not specific to you.
+
+If you've ever read the Bastard Operator From Hell series, you'll
+recall the Dummy Mode.
+
+ The words "power surging" and "drivers" have got her. People hear
+ words like that and go into Dummy Mode and do ANYTHING you say. I
+ could tell her to run naked across campus with a powercord rammed
+ up her backside and she'd probably do it... Hmmm...
+
+There seems to be a Dummy Mode WRT testing. An otherwise competent
+person goes to write a test and they suddenly forget all basic
+programming practice.
+
+
+The reasons for using an C<ok()> function above are the same reasons to
+use functions in general, we should all know them. We'd laugh our
+heads off at code that repeated as much as your average test does.
+These are newbie mistakes.
+
+And the normal 'can do' flair seems to disappear. I know Robin. I
+*know* that in any other situation he would have come up with the
+C<caller()> trick in about 15 seconds flat. Instead weird, elaborate,
+inelegant hacks are thought up to solve the simplest problems.
+
+
+I guess there are certain programming idioms that are foreign enough
+to throw your brain into reverse if you're not ready for them. Like
+trying to think in Lisp, for example. Or being presented with OO for
+the first time. I guess writing test is one of those.
+
+
+=head2 How do I use Test::More without depending on it?
+
+Install L<Test::More> into F<t/lib> under your source directory. Then in your tests
+say C<use lib 't/lib'>.
+
+=head2 How do I deal with threads and forking?
+
+ use Test::More qw/enable_forking/;
+
+or
+
+ use Test::More qw/modern/;
+
+=head2 Why do I need more than ok?
+
+Since every test can be reduced to checking if a statement is true,
+C<ok()> can test everything. But C<ok()> doesn't tell you why the test
+failed. For that you need to tell the test more... which is why
+you need L<Test::More>.
+
+ ok $pirate->name eq "Roberts", "person's name";
+
+ not ok 1 - person's name
+ # Failed test at pirates.t line 23.
+
+If the above fails, you don't know what C<< $person->name >> returned.
+You have to go in and add a C<diag> call. This is time consuming. If
+it's a heisenbug, it might not fail again! If it's a user reporting a
+test failure, they might not be bothered to hack the tests to give you
+more information.
+
+ is $person->name, "Roberts", "person's name";
+
+ not ok 1 - person's name
+ # Failed test at pirates.t line 23.
+ # got: 'Wesley'
+ # expected: 'Roberts'
+
+Using C<is> from L<Test::More> you now know what value you got and
+what value you expected.
+
+The most useful functions in L<Test::More> are C<is()>, C<like()> and C<is_deeply()>.
+
+
+=head2 What's wrong with C<print $test ? "ok" : "not ok">?
+
+=head2 How do I check for an infinite loop?
+
+On Mon, Mar 18, 2002 at 03:57:55AM -0500, Mark-Jason Dominus wrote:
+>
+> Michael The Schwern <schwern@pobox.com> says:
+> > Use alarm and skip the test if $Config{d_alarm} is false (see
+> > t/op/alarm.t for an example). If you think the infinite loop is due
+> > to a programming glitch, as opposed to a cross-platform issue, this
+> > will be enough.
+>
+> Thanks very much!
+>
+
+=head2 How can I check that flock works?
+
+=head2 How do I use the comparison functions of a testing module without it being a test?
+
+Any testing function based on L<Test::Builder>, most are, can be quieted so it does
+not do any testing. It simply returns true or false. Use the following code...
+
+ use Test::More; # or any testing module
+
+ use Test::Builder;
+ use File::Spec;
+
+ # Get the internal Test::Builder object
+ my $tb = Test::Builder->new;
+
+ $tb->plan("no_plan");
+
+ # Keep Test::Builder from displaying anything
+ $tb->no_diag(1);
+ $tb->no_ending(1);
+ $tb->no_header(1);
+ $tb->output( File::Spec->devnull );
+
+ # Now you can use the testing function.
+ print is_deeply( "foo", "bar" ) ? "Yes" : "No";
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
package Test::More;
-use 5.006;
+use 5.008001;
use strict;
use warnings;
-#---- perlcritic exemptions. ----#
+our $VERSION = '1.301001_075';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+use Test::Stream 1.301001 '-internal';
+use Test::Stream::Util qw/protect try spoof/;
+use Test::Stream::Toolset;
+
+use Test::Stream::Carp qw/croak carp/;
+use Scalar::Util qw/blessed/;
+
+use Test::More::Tools;
+use Test::More::DeepCheck::Strict;
+
+use Test::Builder;
+
+use Test::Stream::Exporter qw/
+ default_export default_exports export_to export_to_level
+/;
+
+our $TODO;
+default_export '$TODO' => \$TODO;
+default_exports qw{
+ plan done_testing
-# We use a lot of subroutine prototypes
-## no critic (Subroutines::ProhibitSubroutinePrototypes)
+ ok
+ is isnt
+ like unlike
+ cmp_ok
+ is_deeply
+ eq_array eq_hash eq_set
+ can_ok isa_ok new_ok
+ pass fail
+ require_ok use_ok
+ subtest
-# 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 {
- my( $file, $line ) = ( caller(1) )[ 1, 2 ];
- return warn @_, " at $file line $line\n";
+ explain
+
+ diag note
+
+ skip todo_skip
+ BAIL_OUT
+};
+Test::Stream::Exporter->cleanup;
+
+{
+ no warnings 'once';
+ $Test::Builder::Level ||= 1;
}
-our $VERSION = '1.001008';
-$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+sub import {
+ my $class = shift;
+ my $caller = caller;
+ my @args = @_;
+
+ my $stash = $class->before_import($caller, \@args) if $class->can('before_import');
+ export_to($class, $caller, @args);
+ $class->after_import($caller, $stash, @args) if $class->can('after_import');
+ $class->import_extra(@args);
+}
-use Test::Builder::Module 0.99;
-our @ISA = qw(Test::Builder::Module);
-our @EXPORT = qw(ok use_ok require_ok
- is isnt like unlike is_deeply
- cmp_ok
- skip todo todo_skip
- pass fail
- eq_array eq_hash eq_set
- $TODO
- plan
- done_testing
- can_ok isa_ok new_ok
- diag note explain
- subtest
- BAIL_OUT
-);
+sub import_extra { 1 };
+
+sub builder { Test::Builder->new }
+
+sub before_import {
+ my $class = shift;
+ my ($importer, $list) = @_;
+
+ my $meta = init_tester($importer);
+
+ my $context = context(1);
+ my $other = [];
+ my $idx = 0;
+
+ while ($idx <= $#{$list}) {
+ my $item = $list->[$idx++];
+ next unless $item;
+
+ if (defined $item and $item eq 'no_diag') {
+ Test::Stream->shared->set_no_diag(1);
+ }
+ elsif ($item eq 'tests') {
+ $context->plan($list->[$idx++]);
+ }
+ elsif ($item eq 'skip_all') {
+ $context->plan(0, 'SKIP', $list->[$idx++]);
+ }
+ elsif ($item eq 'no_plan') {
+ $context->plan(0, 'NO PLAN');
+ }
+ elsif ($item eq 'import') {
+ push @$other => @{$list->[$idx++]};
+ }
+ else {
+ carp("Unknown option: $item");
+ }
+ }
+
+ @$list = @$other;
+
+ return;
+}
+
+sub ok ($;$) {
+ my ($test, $name) = @_;
+ my $ctx = context();
+ if($test) {
+ $ctx->ok(1, $name);
+ return 1;
+ }
+ else {
+ $ctx->ok(0, $name);
+ return 0;
+ }
+}
+
+sub plan {
+ return unless @_;
+ my ($directive, $arg) = @_;
+ my $ctx = context();
+
+ if ($directive eq 'tests') {
+ $ctx->plan($arg);
+ }
+ else {
+ $ctx->plan(0, $directive, $arg);
+ }
+}
+
+sub done_testing {
+ my ($num) = @_;
+ my $ctx = context();
+ $ctx->done_testing($num);
+}
+
+sub is($$;$) {
+ my ($got, $want, $name) = @_;
+ my $ctx = context();
+ my ($ok, @diag) = tmt->is_eq($got, $want);
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
+
+sub isnt ($$;$) {
+ my ($got, $forbid, $name) = @_;
+ my $ctx = context();
+ my ($ok, @diag) = tmt->isnt_eq($got, $forbid);
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
+
+{
+ no warnings 'once';
+ *isn't = \&isnt;
+ # ' to unconfuse syntax higlighters
+}
+
+sub like ($$;$) {
+ my ($got, $check, $name) = @_;
+ my $ctx = context();
+ my ($ok, @diag) = tmt->regex_check($got, $check, '=~');
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
+
+sub unlike ($$;$) {
+ my ($got, $forbid, $name) = @_;
+ my $ctx = context();
+ my ($ok, @diag) = tmt->regex_check($got, $forbid, '!~');
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
+
+sub cmp_ok($$$;$) {
+ my ($got, $type, $expect, $name) = @_;
+ my $ctx = context();
+ my ($ok, @diag) = tmt->cmp_check($got, $type, $expect);
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
+
+sub can_ok($@) {
+ my ($thing, @methods) = @_;
+ my $ctx = context();
+
+ my $class = ref $thing || $thing || '';
+ my ($ok, @diag);
+
+ if (!@methods) {
+ ($ok, @diag) = (0, " can_ok() called with no methods");
+ }
+ elsif (!$class) {
+ ($ok, @diag) = (0, " can_ok() called with empty class or reference");
+ }
+ else {
+ ($ok, @diag) = tmt->can_check($thing, $class, @methods);
+ }
+
+ my $name = (@methods == 1 && defined $methods[0])
+ ? "$class\->can('$methods[0]')"
+ : "$class\->can(...)";
+
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
+
+sub isa_ok ($$;$) {
+ my ($thing, $class, $thing_name) = @_;
+ my $ctx = context();
+ $thing_name = "'$thing_name'" if $thing_name;
+ my ($ok, @diag) = tmt->isa_check($thing, $class, \$thing_name);
+ my $name = "$thing_name isa '$class'";
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
+
+sub new_ok {
+ croak "new_ok() must be given at least a class" unless @_;
+ my ($class, $args, $object_name) = @_;
+ my $ctx = context();
+ my ($obj, $name, $ok, @diag) = tmt->new_check($class, $args, $object_name);
+ $ctx->ok($ok, $name, \@diag);
+ return $obj;
+}
+
+sub pass (;$) {
+ my $ctx = context();
+ return $ctx->ok(1, @_);
+}
+
+sub fail (;$) {
+ my $ctx = context();
+ return $ctx->ok(0, @_);
+}
+
+sub subtest {
+ my $ctx = context();
+ return tmt->subtest(@_);
+}
+
+sub explain {
+ my $ctx = context();
+ tmt->explain(@_);
+}
+
+sub diag {
+ my $ctx = context();
+ $ctx->diag($_) for @_;
+}
+
+sub note {
+ my $ctx = context();
+ $ctx->note($_) for @_;
+}
+
+sub skip {
+ my( $why, $how_many ) = @_;
+ my $ctx = context();
+
+ _skip($why, $how_many, 'skip', 1);
+
+ no warnings 'exiting';
+ last SKIP;
+}
+
+sub _skip {
+ my( $why, $how_many, $func, $bool ) = @_;
+ my $ctx = context();
+
+ my $plan = $ctx->stream->plan;
+
+ # If there is no plan we do not need to worry about counts
+ my $need_count = $plan ? !($plan->directive && $plan->directive eq 'NO PLAN') : 0;
+
+ if ($need_count && !defined $how_many) {
+ $ctx->alert("$func() needs to know \$how_many tests are in the block");
+ }
+
+ $ctx->alert("$func() was passed a non-numeric number of tests. Did you get the arguments backwards?")
+ if defined $how_many and $how_many =~ /\D/;
+
+ $how_many = 1 unless defined $how_many;
+ $ctx->set_skip($why);
+ for( 1 .. $how_many ) {
+ $ctx->ok($bool, '');
+ }
+}
+
+sub todo_skip {
+ my($why, $how_many) = @_;
+
+ my $ctx = context();
+ $ctx->set_in_todo(1);
+ $ctx->set_todo($why);
+ _skip($why, $how_many, 'todo_skip', 0);
+
+ no warnings 'exiting';
+ last TODO;
+}
+
+sub BAIL_OUT {
+ my ($reason) = @_;
+ my $ctx = context();
+ $ctx->bail($reason);
+}
+
+sub is_deeply {
+ my ($got, $want, $name) = @_;
+
+ my $ctx = context();
+
+ unless( @_ == 2 or @_ == 3 ) {
+ my $msg = <<'WARNING';
+is_deeply() takes two or three args, you gave %d.
+This usually means you passed an array or hash instead
+of a reference to it
+WARNING
+ chop $msg; # clip off newline so carp() will put in line/file
+
+ $ctx->alert(sprintf $msg, scalar @_);
+
+ $ctx->ok(0, undef, ['incorrect number of args']);
+ return 0;
+ }
+
+ my ($ok, @diag) = Test::More::DeepCheck::Strict->check($got, $want);
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
+
+sub eq_array {
+ my ($got, $want, $name) = @_;
+ my $ctx = context();
+ my ($ok, @diag) = Test::More::DeepCheck::Strict->check_array($got, $want);
+ return $ok;
+}
+
+sub eq_hash {
+ my ($got, $want, $name) = @_;
+ my $ctx = context();
+ my ($ok, @diag) = Test::More::DeepCheck::Strict->check_hash($got, $want);
+ return $ok;
+}
+
+sub eq_set {
+ my ($got, $want, $name) = @_;
+ my $ctx = context();
+ my ($ok, @diag) = Test::More::DeepCheck::Strict->check_set($got, $want);
+ return $ok;
+}
+
+sub require_ok($;$) {
+ my($module) = shift;
+ my $ctx = context();
+
+ # Try to determine if we've been given a module name or file.
+ # Module names must be barewords, files not.
+ $module = qq['$module'] unless _is_module_name($module);
+
+ my ($ret, $err);
+ {
+ local $SIG{__DIE__};
+ ($ret, $err) = spoof [caller] => "require $module";
+ }
+
+ my @diag;
+ unless ($ret) {
+ chomp $err;
+ push @diag => <<" DIAG";
+ Tried to require '$module'.
+ Error: $err
+ DIAG
+ }
+
+ $ctx->ok( $ret, "require $module;", \@diag );
+ return $ret ? 1 : 0;
+}
+
+sub _is_module_name {
+ my $module = shift;
+
+ # Module names start with a letter.
+ # End with an alphanumeric.
+ # The rest is an alphanumeric or ::
+ $module =~ s/\b::\b//g;
+
+ return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
+}
+
+sub use_ok($;@) {
+ my ($module, @imports) = @_;
+ @imports = () unless @imports;
+ my $ctx = context();
+
+ my($pack, $filename, $line) = caller;
+ $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line
+
+ my ($ret, $err, $newdie, @diag);
+ {
+ local $SIG{__DIE__};
+
+ if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
+ # probably a version check. Perl needs to see the bare number
+ # for it to work with non-Exporter based modules.
+ ($ret, $err) = spoof [$pack, $filename, $line] => "use $module $imports[0]";
+ }
+ else {
+ ($ret, $err) = spoof [$pack, $filename, $line] => "use $module \@args", @imports;
+ }
+
+ $newdie = $SIG{__DIE__};
+ }
+
+ $SIG{__DIE__} = $newdie if defined $newdie;
+
+ unless ($ret) {
+ chomp $err;
+ push @diag => <<" DIAG";
+ Tried to use '$module'.
+ Error: $err
+ DIAG
+ }
+
+ $ctx->ok($ret, "use $module;", \@diag);
+
+ return $ret ? 1 : 0;
+}
+
+1;
+
+__END__
=head1 NAME
-Test::More - yet another framework for writing test scripts
+Test::More - The defacto standard in unit testing tools.
=head1 SYNOPSIS
- use Test::More tests => 23;
- # or
- use Test::More skip_all => $reason;
- # or
- use Test::More; # see done_testing()
+ # Using Test::Stream BEFORE using Test::More removes expensive legacy
+ # support. This Also provides context(), cull(), and tap_encoding()
+ use Test::Stream;
- require_ok( 'Some::Module' );
+ # Load after Test::Stream to get the benefits of removed legacy
+ use Test::More;
- # Various ways to say "ok"
- ok($got eq $expected, $test_name);
+ use ok 'Some::Module';
- is ($got, $expected, $test_name);
- isnt($got, $expected, $test_name);
+ can_ok($module, @methods);
+ isa_ok($object, $class);
- # Rather than print STDERR "# here's what went wrong\n"
- diag("here's what went wrong");
+ pass($test_name);
+ fail($test_name);
- like ($got, qr/expected/, $test_name);
- unlike($got, qr/expected/, $test_name);
+ ok($got eq $expected, $test_name);
- cmp_ok($got, '==', $expected, $test_name);
+ is ($got, $expected, $test_name);
+ isnt($got, $expected, $test_name);
- is_deeply($got_complex_structure, $expected_complex_structure, $test_name);
+ like ($got, qr/expected/, $test_name);
+ unlike($got, qr/expected/, $test_name);
- SKIP: {
- skip $why, $how_many unless $have_some_feature;
+ cmp_ok($got, '==', $expected, $test_name);
- ok( foo(), $test_name );
- is( foo(42), 23, $test_name );
- };
-
- TODO: {
- local $TODO = $why;
+ is_deeply(
+ $got_complex_structure,
+ $expected_complex_structure,
+ $test_name
+ );
- ok( foo(), $test_name );
- is( foo(42), 23, $test_name );
- };
+ # Rather than print STDERR "# here's what went wrong\n"
+ diag("here's what went wrong");
- can_ok($module, @methods);
- isa_ok($object, $class);
+ SKIP: {
+ skip $why, $how_many unless $have_some_feature;
- pass($test_name);
- fail($test_name);
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ };
- BAIL_OUT($why);
+ TODO: {
+ local $TODO = $why;
+
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ };
+
+ sub my_compare {
+ my ($got, $want, $name) = @_;
+ my $ctx = context(); # From Test::Stream
+ my $ok = $got eq $want;
+ $ctx->ok($ok, $name);
+ ...
+ return $ok;
+ };
- # UNIMPLEMENTED!!!
- my @status = Test::More::status;
+ # If this fails it will report this line instead of the line in my_compare.
+ my_compare('a', 'b');
+ done_testing;
=head1 DESCRIPTION
data structures. While you can do almost anything with a simple
C<ok()> function, it doesn't provide good diagnostic output.
-
=head2 I love it when a plan comes together
Before anything else, you need a testing plan. This basically declares
plan tests => 42;
}
-=cut
-
-sub plan {
- my $tb = Test::More->builder;
-
- return $tb->plan(@_);
-}
-
-# This implements "use Test::More 'no_diag'" but the behavior is
-# deprecated.
-sub import_extra {
- my $class = shift;
- my $list = shift;
-
- my @other = ();
- my $idx = 0;
- while( $idx <= $#{$list} ) {
- my $item = $list->[$idx];
-
- if( defined $item and $item eq 'no_diag' ) {
- $class->builder->no_diag(1);
- }
- else {
- push @other, $item;
- }
-
- $idx++;
- }
-
- @$list = @other;
-
- return;
-}
-
=over 4
=item B<done_testing>
=back
-=cut
+=head2 Test::Stream
-sub done_testing {
- my $tb = Test::More->builder;
- $tb->done_testing(@_);
-}
+If Test::Stream is loaded before Test::More then it will prevent the insertion
+of some legacy support shims, saving you memory and improving performance.
+
+ use Test::Stream;
+ use Test::More;
+
+You can also use it to make forking work:
+
+ use Test::Stream 'enable_fork';
+
+=head2 TAP Encoding
+
+You can now control the encoding of your TAP output using Test::Stream.
+
+ use Test::Stream; # imports tap_encoding
+ use Test::More;
+
+ tap_encoding 'utf8';
+
+You can also just set 'utf8' it at import time
+
+ use Test::Stream 'utf8';
+
+or something other than utf8
+
+ use Test::Stream encoding => 'latin1';
+
+=over 4
+
+=item tap_encoding 'utf8';
+
+=item tap_encoding 'YOUR_ENCODING';
+
+=item tap_encoding 'xxx' => sub { ... };
+
+The C<tap_encoding($encoding)> function will ensure that any B<FUTURE> TAP
+output produced by I<This Package> will be output in the specified encoding.
+
+You may also provide a codeblock in which case the scope of the encoding change
+will only apply to that codeblock.
+
+B<Note>: This is effective only for the current package. Other packages can/may
+select other encodings for their TAP output. For packages where none is
+specified, the original STDOUT and STDERR settings are used, the results are
+unpredictable.
+
+B<Note>: The encoding of the TAP, it is necessary to set to match the
+locale of the encoding of the terminal.
+
+However, in tests code that are performed in a variety of environments,
+it can not be assumed in advance the encoding of the locale of the terminal,
+it is recommended how to set the encoding to your environment using the
+C<Encode::Locale> module.
+
+The following is an example of code.
+
+ use utf8;
+ use Test::Stream;
+ use Test::More;
+ use Encode::Locale;
+
+ tap_encoding('console_out');
+
+B<Note>: Filenames are a touchy subject:
+
+Different OS's and filesystems handle filenames differently. When you do not
+specify an encoding, the filename will be unmodified, you get whatever perl
+thinks it is. If you do specify an encoding, the filename will be assumed to be
+in that encoding, and an attempt will be made to unscramble it. If the
+unscrambling fails the original name will be used.
+
+This filename unscrambling is necessary for example on linux systems when you
+use utf8 encoding and a utf8 filename. Perl will read the bytes of the name,
+and treat them as bytes. if you then try to print the name to a utf8 handle it
+will treat each byte as a different character. Test::More attempts to fix this
+scrambling for you.
+
+=back
+
+=head2 Helpers
+
+Sometimes you want to write functions for things you do frequently that include
+calling ok() or other test functions. Doing this can make it hard to debug
+problems as failures will be reported in your sub, and not at the place where
+you called your sub. Now there is a solution to this, the
+L<Test::Stream::Context> object!.
+
+L<Test::Stream> exports the C<context()> function which will return a context
+object for your use. The idea is that you generate a context object at the
+lowest level (the function you call from your test file). Deeper functions that
+need context will get the object you already generated, at least until the
+object falls out of scope or is undefined.
+
+ sub my_compare {
+ my ($got, $want, $name) = @_;
+ my $ctx = context();
+
+ # is() will find the context object above, instead of generating a new
+ # one. That way a failure will be reported to the correct line
+ is($got, $want);
+
+ # This time it will generate a new context object. That means a failure
+ # will report to this line.
+ $ctx = undef;
+ is($got, $want);
+ };
=head2 Test names
This is the same as L<Test::Simple>'s C<ok()> routine.
-=cut
-
-sub ok ($;$) {
- my( $test, $name ) = @_;
- my $tb = Test::More->builder;
-
- return $tb->ok( $test, $name );
-}
-
=item B<is>
=item B<isnt>
For those grammatical pedants out there, there's an C<isn't()>
function which is an alias of C<isnt()>.
-=cut
-
-sub is ($$;$) {
- my $tb = Test::More->builder;
-
- return $tb->is_eq(@_);
-}
-
-sub isnt ($$;$) {
- my $tb = Test::More->builder;
-
- return $tb->isnt_eq(@_);
-}
-
-*isn't = \&isnt;
-# ' to unconfuse syntax higlighters
-
=item B<like>
like( $got, qr/expected/, $test_name );
Its advantages over C<ok()> are similar to that of C<is()> and C<isnt()>. Better
diagnostics on failure.
-=cut
-
-sub like ($$;$) {
- my $tb = Test::More->builder;
-
- return $tb->like(@_);
-}
-
=item B<unlike>
unlike( $got, qr/expected/, $test_name );
Works exactly as C<like()>, only it checks if $got B<does not> match the
given pattern.
-=cut
-
-sub unlike ($$;$) {
- my $tb = Test::More->builder;
-
- return $tb->unlike(@_);
-}
-
=item B<cmp_ok>
cmp_ok( $got, $op, $expected, $test_name );
cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
-It's especially useful when comparing greater-than or smaller-than
+It's especially useful when comparing greater-than or smaller-than
relation between values:
cmp_ok( $some_value, '<=', $upper_limit );
-
-=cut
-
-sub cmp_ok($$$;$) {
- my $tb = Test::More->builder;
-
- return $tb->cmp_ok(@_);
-}
-
=item B<can_ok>
can_ok($module, @methods);
is almost exactly like saying:
- ok( Foo->can('this') &&
- Foo->can('that') &&
- Foo->can('whatever')
+ ok( Foo->can('this') &&
+ Foo->can('that') &&
+ Foo->can('whatever')
);
only without all the typing and with a better interface. Handy for
can_ok('Foo', $meth);
}
-=cut
-
-sub can_ok ($@) {
- my( $proto, @methods ) = @_;
- my $class = ref $proto || $proto;
- my $tb = Test::More->builder;
-
- unless($class) {
- my $ok = $tb->ok( 0, "->can(...)" );
- $tb->diag(' can_ok() called with empty class or reference');
- return $ok;
- }
-
- unless(@methods) {
- my $ok = $tb->ok( 0, "$class->can(...)" );
- $tb->diag(' can_ok() called with no methods');
- return $ok;
- }
-
- my @nok = ();
- foreach my $method (@methods) {
- $tb->_try( sub { $proto->can($method) } ) or push @nok, $method;
- }
-
- my $name = (@methods == 1) ? "$class->can('$methods[0]')" :
- "$class->can(...)" ;
-
- my $ok = $tb->ok( !@nok, $name );
-
- $tb->diag( map " $class->can('$_') failed\n", @nok );
-
- return $ok;
-}
-
=item B<isa_ok>
isa_ok($object, $class, $object_name);
you'd like them to be more specific, you can supply an $object_name
(for example 'Test customer').
-=cut
-
-sub isa_ok ($$;$) {
- my( $thing, $class, $thing_name ) = @_;
- my $tb = Test::More->builder;
-
- my $whatami;
- if( !defined $thing ) {
- $whatami = 'undef';
- }
- elsif( ref $thing ) {
- $whatami = 'reference';
-
- local($@,$!);
- require Scalar::Util;
- if( Scalar::Util::blessed($thing) ) {
- $whatami = 'object';
- }
- }
- else {
- $whatami = 'class';
- }
-
- # We can't use UNIVERSAL::isa because we want to honor isa() overrides
- my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } );
-
- if($error) {
- die <<WHOA unless $error =~ /^Can't (locate|call) method "isa"/;
-WHOA! I tried to call ->isa on your $whatami and got some weird error.
-Here's the error.
-$error
-WHOA
- }
-
- # Special case for isa_ok( [], "ARRAY" ) and like
- if( $whatami eq 'reference' ) {
- $rslt = UNIVERSAL::isa($thing, $class);
- }
-
- my($diag, $name);
- if( defined $thing_name ) {
- $name = "'$thing_name' isa '$class'";
- $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined";
- }
- elsif( $whatami eq 'object' ) {
- my $my_class = ref $thing;
- $thing_name = qq[An object of class '$my_class'];
- $name = "$thing_name isa '$class'";
- $diag = "The object of class '$my_class' isn't a '$class'";
- }
- elsif( $whatami eq 'reference' ) {
- my $type = ref $thing;
- $thing_name = qq[A reference of type '$type'];
- $name = "$thing_name isa '$class'";
- $diag = "The reference of type '$type' isn't a '$class'";
- }
- elsif( $whatami eq 'undef' ) {
- $thing_name = 'undef';
- $name = "$thing_name isa '$class'";
- $diag = "$thing_name isn't defined";
- }
- elsif( $whatami eq 'class' ) {
- $thing_name = qq[The class (or class-like) '$thing'];
- $name = "$thing_name isa '$class'";
- $diag = "$thing_name isn't a '$class'";
- }
- else {
- die;
- }
-
- my $ok;
- if($rslt) {
- $ok = $tb->ok( 1, $name );
- }
- else {
- $ok = $tb->ok( 0, $name );
- $tb->diag(" $diag\n");
- }
-
- return $ok;
-}
-
=item B<new_ok>
my $obj = new_ok( $class );
This function only works on C<new()> and it assumes C<new()> will return
just a single object which isa C<$class>.
-=cut
-
-sub new_ok {
- my $tb = Test::More->builder;
- $tb->croak("new_ok() must be given at least a class") unless @_;
-
- my( $class, $args, $object_name ) = @_;
-
- $args ||= [];
-
- my $obj;
- my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } );
- if($success) {
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- isa_ok $obj, $class, $object_name;
- }
- else {
- $class = 'undef' if !defined $class;
- $tb->ok( 0, "$class->new() died" );
- $tb->diag(" Error was: $error");
- }
-
- return $obj;
-}
-
=item B<subtest>
subtest $name => \&code;
For example...
use Test::More tests => 3;
-
+
pass("First test");
subtest 'An example subtest' => sub {
done_testing();
};
-=cut
-
-sub subtest {
- my ($name, $subtests) = @_;
-
- my $tb = Test::More->builder;
- return $tb->subtest(@_);
-}
-
=item B<pass>
=item B<fail>
Use these very, very, very sparingly.
-=cut
+=back
-sub pass (;$) {
- my $tb = Test::More->builder;
+=head2 Debugging tests
- return $tb->ok( 1, @_ );
-}
+Want a stack trace when a test failure occurs? Have some other hook in mind?
+Easy!
-sub fail (;$) {
- my $tb = Test::More->builder;
+ use Test::More;
+ use Carp qw/confess/;
- return $tb->ok( 0, @_ );
-}
+ Test::Stream->shared->listen(sub {
+ my ($stream, $event) = @_;
-=back
+ # Only care about 'Ok' events (this includes subtests)
+ return unless $event->isa('Test::Stream::Event::Ok');
+ # Only care about failures
+ return if $event->bool;
+
+ confess "Failed test! here is a stacktrace!";
+ });
+
+ ok(0, "This will give you a trace.");
=head2 Module tests
simply loads all the modules in the distribution to make sure they
work before going on to do more complicated testing.
-For such purposes we have C<use_ok> and C<require_ok>.
+For such purposes we have C<use ok 'module'>. C<use_ok> is still around, but is
+considered discouraged in favor of C<use ok 'module'>. C<require_ok> is also
+discouraged because it tries to guess if you gave it a file name or module
+name. C<require_ok>'s guessing mechanism is broken, but fixing it can break
+things.
=over 4
-=item B<require_ok>
+=item B<use ok 'module'>
- require_ok($module);
- require_ok($file);
+=item B<use ok 'module', @args>
-Tries to C<require> the given $module or $file. If it loads
-successfully, the test will pass. Otherwise it fails and displays the
-load error.
+ use ok 'Some::Module';
+ use ok 'Another::Module', qw/import_a import_b/;
-C<require_ok> will guess whether the input is a module name or a
-filename.
+This will load the specified module and pass through any extra arguments to
+that module. This will also produce a test result.
-No exception will be thrown if the load fails.
-
- # require Some::Module
- require_ok "Some::Module";
-
- # require "Some/File.pl";
- require_ok "Some/File.pl";
-
- # stop testing if any of your modules will not load
- for my $module (@module) {
- require_ok $module or BAIL_OUT "Can't load $module";
- }
+B<Note - Do not do this:>
-=cut
+ my $class = 'My::Module';
+ use ok $class;
-sub require_ok ($) {
- my($module) = shift;
- my $tb = Test::More->builder;
+The value 'My::Module' is not assigned to the C<$class> variable until
+run-time, but the C<use ok $class> statement is run at compile time. The result
+of this is that we try to load 'undef' as a module. This will generate an
+exception: C<'use ok' called with an empty argument, did you try to use a package name from an uninitialized variable?>
- my $pack = caller;
+If you must do something like this, here is a more-correct way:
- # Try to determine if we've been given a module name or file.
- # Module names must be barewords, files not.
- $module = qq['$module'] unless _is_module_name($module);
+ my $class;
+ BEGIN { $class = 'My::Module' }
+ use ok $class;
- my $code = <<REQUIRE;
-package $pack;
-require $module;
-1;
-REQUIRE
+=item B<require_ok>
- my( $eval_result, $eval_error ) = _eval($code);
- my $ok = $tb->ok( $eval_result, "require $module;" );
+B<***DISCOURAGED***> - Broken guessing
- unless($ok) {
- chomp $eval_error;
- $tb->diag(<<DIAGNOSTIC);
- Tried to require '$module'.
- Error: $eval_error
-DIAGNOSTIC
+ require_ok($module);
+ require_ok($file);
- }
+Tries to C<require> the given $module or $file. If it loads
+successfully, the test will pass. Otherwise it fails and displays the
+load error.
- return $ok;
-}
+C<require_ok> will guess whether the input is a module name or a
+filename.
-sub _is_module_name {
- my $module = shift;
+No exception will be thrown if the load fails.
- # Module names start with a letter.
- # End with an alphanumeric.
- # The rest is an alphanumeric or ::
- $module =~ s/\b::\b//g;
+ # require Some::Module
+ require_ok "Some::Module";
- return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
-}
+ # require "Some/File.pl";
+ require_ok "Some/File.pl";
+ # stop testing if any of your modules will not load
+ for my $module (@module) {
+ require_ok $module or BAIL_OUT "Can't load $module";
+ }
=item B<use_ok>
+B<***DISCOURAGED***> See C<use ok 'module'>
+
BEGIN { use_ok($module); }
BEGIN { use_ok($module, @imports); }
BEGIN { require_ok "Foo" }
-=cut
-
-sub use_ok ($;@) {
- my( $module, @imports ) = @_;
- @imports = () unless @imports;
- my $tb = Test::More->builder;
-
- my( $pack, $filename, $line ) = caller;
- $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line
-
- my $code;
- if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
- # probably a version check. Perl needs to see the bare number
- # for it to work with non-Exporter based modules.
- $code = <<USE;
-package $pack;
-
-#line $line $filename
-use $module $imports[0];
-1;
-USE
- }
- else {
- $code = <<USE;
-package $pack;
-
-#line $line $filename
-use $module \@{\$args[0]};
-1;
-USE
- }
-
- my( $eval_result, $eval_error ) = _eval( $code, \@imports );
- my $ok = $tb->ok( $eval_result, "use $module;" );
-
- unless($ok) {
- chomp $eval_error;
- $@ =~ s{^BEGIN failed--compilation aborted at .*$}
- {BEGIN failed--compilation aborted at $filename line $line.}m;
- $tb->diag(<<DIAGNOSTIC);
- Tried to use '$module'.
- Error: $eval_error
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-sub _eval {
- my( $code, @args ) = @_;
-
- # Work around oddities surrounding resetting of $@ by immediately
- # storing it.
- my( $sigdie, $eval_result, $eval_error );
- {
- local( $@, $!, $SIG{__DIE__} ); # isolate eval
- $eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval)
- $eval_error = $@;
- $sigdie = $SIG{__DIE__} || undef;
- }
- # make sure that $code got a chance to set $SIG{__DIE__}
- $SIG{__DIE__} = $sigdie if defined $sigdie;
-
- return( $eval_result, $eval_error );
-}
-
-
=back
-
=head2 Complex data structures
Not everything is a simple eq check or regex. There are times you
L<Test::Differences> and L<Test::Deep> provide more in-depth functionality
along these lines.
-=cut
-
-our( @Data_Stack, %Refs_Seen );
-my $DNE = bless [], 'Does::Not::Exist';
-
-sub _dne {
- return ref $_[0] eq ref $DNE;
-}
-
-## no critic (Subroutines::RequireArgUnpacking)
-sub is_deeply {
- my $tb = Test::More->builder;
-
- unless( @_ == 2 or @_ == 3 ) {
- my $msg = <<'WARNING';
-is_deeply() takes two or three args, you gave %d.
-This usually means you passed an array or hash instead
-of a reference to it
-WARNING
- chop $msg; # clip off newline so carp() will put in line/file
-
- _carp sprintf $msg, scalar @_;
-
- return $tb->ok(0);
- }
-
- my( $got, $expected, $name ) = @_;
-
- $tb->_unoverload_str( \$expected, \$got );
-
- my $ok;
- if( !ref $got and !ref $expected ) { # neither is a reference
- $ok = $tb->is_eq( $got, $expected, $name );
- }
- elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
- $ok = $tb->ok( 0, $name );
- $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
- }
- else { # both references
- local @Data_Stack = ();
- if( _deep_check( $got, $expected ) ) {
- $ok = $tb->ok( 1, $name );
- }
- else {
- $ok = $tb->ok( 0, $name );
- $tb->diag( _format_stack(@Data_Stack) );
- }
- }
-
- return $ok;
-}
-
-sub _format_stack {
- my(@Stack) = @_;
-
- my $var = '$FOO';
- my $did_arrow = 0;
- foreach my $entry (@Stack) {
- my $type = $entry->{type} || '';
- my $idx = $entry->{'idx'};
- if( $type eq 'HASH' ) {
- $var .= "->" unless $did_arrow++;
- $var .= "{$idx}";
- }
- elsif( $type eq 'ARRAY' ) {
- $var .= "->" unless $did_arrow++;
- $var .= "[$idx]";
- }
- elsif( $type eq 'REF' ) {
- $var = "\${$var}";
- }
- }
-
- my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ];
- my @vars = ();
- ( $vars[0] = $var ) =~ s/\$FOO/ \$got/;
- ( $vars[1] = $var ) =~ s/\$FOO/\$expected/;
-
- my $out = "Structures begin differing at:\n";
- foreach my $idx ( 0 .. $#vals ) {
- my $val = $vals[$idx];
- $vals[$idx]
- = !defined $val ? 'undef'
- : _dne($val) ? "Does not exist"
- : ref $val ? "$val"
- : "'$val'";
- }
-
- $out .= "$vars[0] = $vals[0]\n";
- $out .= "$vars[1] = $vals[1]\n";
-
- $out =~ s/^/ /msg;
- return $out;
-}
-
-sub _type {
- my $thing = shift;
-
- return '' if !ref $thing;
-
- for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) {
- return $type if UNIVERSAL::isa( $thing, $type );
- }
-
- return '';
-}
=back
note("Tempfile is $tempfile");
-=cut
-
-sub diag {
- return Test::More->builder->diag(@_);
-}
-
-sub note {
- return Test::More->builder->note(@_);
-}
-
=item B<explain>
my @dump = explain @diagnostic_message;
note explain \%args;
Some::Class->method(%args);
-=cut
-
-sub explain {
- return Test::More->builder->explain(@_);
-}
-
=back
Sometimes running a test under certain conditions will cause the
test script to die. A certain function or method isn't implemented
-(such as C<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).
program, or for which you don't yet have code written. For that you
use TODO. Read on.
-=cut
-
-## no critic (Subroutines::RequireFinalReturn)
-sub skip {
- my( $why, $how_many ) = @_;
- my $tb = Test::More->builder;
-
- unless( defined $how_many ) {
- # $how_many can only be avoided when no_plan is in use.
- _carp "skip() needs to know \$how_many tests are in the block"
- unless $tb->has_plan eq 'no_plan';
- $how_many = 1;
- }
-
- if( defined $how_many and $how_many =~ /\D/ ) {
- _carp
- "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
- $how_many = 1;
- }
-
- for( 1 .. $how_many ) {
- $tb->skip($why);
- }
-
- no warnings 'exiting';
- last SKIP;
-}
-
=item B<TODO: BLOCK>
TODO: {
tests will be marked as failing but todo. L<Test::Harness> will
interpret them as passing.
-=cut
-
-sub todo_skip {
- my( $why, $how_many ) = @_;
- my $tb = Test::More->builder;
-
- unless( defined $how_many ) {
- # $how_many can only be avoided when no_plan is in use.
- _carp "todo_skip() needs to know \$how_many tests are in the block"
- unless $tb->has_plan eq 'no_plan';
- $how_many = 1;
- }
-
- for( 1 .. $how_many ) {
- $tb->todo_skip($why);
- }
-
- no warnings 'exiting';
- last TODO;
-}
=item When do I use SKIP vs. TODO?
For even better control look at L<Test::Most>.
-=cut
-
-sub BAIL_OUT {
- my $reason = shift;
- my $tb = Test::More->builder;
-
- $tb->BAIL_OUT($reason);
-}
-
=back
-
=head2 Discouraged comparison functions
The use of the following functions is discouraged as they are not
ok( eq_array(\@got, \@expected) );
-C<is_deeply()> can do that better and with diagnostics.
+C<is_deeply()> can do that better and with diagnostics.
is_deeply( \@got, \@expected );
Checks if two arrays are equivalent. This is a deep check, so
multi-level structures are handled correctly.
-=cut
-
-#'#
-sub eq_array {
- local @Data_Stack = ();
- _deep_check(@_);
-}
-
-sub _eq_array {
- my( $a1, $a2 ) = @_;
-
- if( grep _type($_) ne 'ARRAY', $a1, $a2 ) {
- warn "eq_array passed a non-array ref";
- return 0;
- }
-
- return 1 if $a1 eq $a2;
-
- my $ok = 1;
- my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
- for( 0 .. $max ) {
- my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
- my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
-
- next if _equal_nonrefs($e1, $e2);
-
- push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
- $ok = _deep_check( $e1, $e2 );
- pop @Data_Stack if $ok;
-
- last unless $ok;
- }
-
- return $ok;
-}
-
-sub _equal_nonrefs {
- my( $e1, $e2 ) = @_;
-
- return if ref $e1 or ref $e2;
-
- if ( defined $e1 ) {
- return 1 if defined $e2 and $e1 eq $e2;
- }
- else {
- return 1 if !defined $e2;
- }
-
- return;
-}
-
-sub _deep_check {
- my( $e1, $e2 ) = @_;
- my $tb = Test::More->builder;
-
- my $ok = 0;
-
- # Effectively turn %Refs_Seen into a stack. This avoids picking up
- # the same referenced used twice (such as [\$a, \$a]) to be considered
- # circular.
- local %Refs_Seen = %Refs_Seen;
-
- {
- $tb->_unoverload_str( \$e1, \$e2 );
-
- # Either they're both references or both not.
- my $same_ref = !( !ref $e1 xor !ref $e2 );
- my $not_ref = ( !ref $e1 and !ref $e2 );
-
- if( defined $e1 xor defined $e2 ) {
- $ok = 0;
- }
- elsif( !defined $e1 and !defined $e2 ) {
- # Shortcut if they're both undefined.
- $ok = 1;
- }
- elsif( _dne($e1) xor _dne($e2) ) {
- $ok = 0;
- }
- elsif( $same_ref and( $e1 eq $e2 ) ) {
- $ok = 1;
- }
- elsif($not_ref) {
- push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
- $ok = 0;
- }
- else {
- if( $Refs_Seen{$e1} ) {
- return $Refs_Seen{$e1} eq $e2;
- }
- else {
- $Refs_Seen{$e1} = "$e2";
- }
-
- my $type = _type($e1);
- $type = 'DIFFERENT' unless _type($e2) eq $type;
-
- if( $type eq 'DIFFERENT' ) {
- push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
- $ok = 0;
- }
- elsif( $type eq 'ARRAY' ) {
- $ok = _eq_array( $e1, $e2 );
- }
- elsif( $type eq 'HASH' ) {
- $ok = _eq_hash( $e1, $e2 );
- }
- elsif( $type eq 'REF' ) {
- push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
- $ok = _deep_check( $$e1, $$e2 );
- pop @Data_Stack if $ok;
- }
- elsif( $type eq 'SCALAR' ) {
- push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
- $ok = _deep_check( $$e1, $$e2 );
- pop @Data_Stack if $ok;
- }
- elsif($type) {
- push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
- $ok = 0;
- }
- else {
- _whoa( 1, "No type in _deep_check" );
- }
- }
- }
-
- return $ok;
-}
-
-sub _whoa {
- my( $check, $desc ) = @_;
- if($check) {
- die <<"WHOA";
-WHOA! $desc
-This should never happen! Please contact the author immediately!
-WHOA
- }
-}
-
=item B<eq_hash>
my $is_eq = eq_hash(\%got, \%expected);
Determines if the two hashes contain the same keys and values. This
is a deep check.
-=cut
-
-sub eq_hash {
- local @Data_Stack = ();
- return _deep_check(@_);
-}
-
-sub _eq_hash {
- my( $a1, $a2 ) = @_;
-
- if( grep _type($_) ne 'HASH', $a1, $a2 ) {
- warn "eq_hash passed a non-hash ref";
- return 0;
- }
-
- return 1 if $a1 eq $a2;
-
- my $ok = 1;
- my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
- foreach my $k ( keys %$bigger ) {
- my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
- my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
-
- next if _equal_nonrefs($e1, $e2);
-
- push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
- $ok = _deep_check( $e1, $e2 );
- pop @Data_Stack if $ok;
-
- last unless $ok;
- }
-
- return $ok;
-}
=item B<eq_set>
L<Test::Deep> contains much better set comparison functions.
-=cut
-
-sub eq_set {
- my( $a1, $a2 ) = @_;
- return 0 unless @$a1 == @$a2;
-
- no warnings 'uninitialized';
-
- # It really doesn't matter how we sort them, as long as both arrays are
- # sorted with the same algorithm.
- #
- # Ensure that references are not accidentally treated the same as a
- # string containing the reference.
- #
- # Have to inline the sort routine due to a threading/sort bug.
- # See [rt.cpan.org 6782]
- #
- # I don't know how references would be sorted so we just don't sort
- # them. This means eq_set doesn't really work with refs.
- return eq_array(
- [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
- [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
- );
-}
-
=back
=head2 Extending and Embedding Test::More
Sometimes the Test::More interface isn't quite enough. Fortunately,
-Test::More is built on top of L<Test::Builder> which provides a single,
+Test::More is built on top of L<Test::Stream> 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::Stream> 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 L<Test::Builder> object like so:
-
-=over 4
-
-=item B<builder>
-
- my $test_builder = Test::More->builder;
-
-Returns the L<Test::Builder> object underlying Test::More for you to play
-with.
-
-
-=back
-
-
=head1 EXIT CODES
If all your tests passed, L<Test::Builder> will exit with zero (which is
Thread support is not very reliable before 5.10.1, but that's
because threads are not very reliable before 5.10.1.
-Although Test::More has been a core module in versions of Perl since 5.6.2, Test::More has evolved since then, and not all of the features you're used to will be present in the shipped version of Test::More. If you are writing a module, don't forget to indicate in your package metadata the minimum version of Test::More that you require. For instance, if you want to use C<done_testing()> but want your test script to run on Perl 5.10.0, you will need to explicitly require Test::More > 0.88.
+Although Test::More has been a core module in versions of Perl since 5.6.2,
+Test::More has evolved since then, and not all of the features you're used to
+will be present in the shipped version of Test::More. If you are writing a
+module, don't forget to indicate in your package metadata the minimum version
+of Test::More that you require. For instance, if you want to use
+C<done_testing()> but want your test script to run on Perl 5.10.0, you will
+need to explicitly require Test::More > 0.88.
Key feature milestones include:
=over 4
+=item event stream
+
+=item forking support
+
+=item tap encoding
+
+Test::Builder and Test::More version 1.301001 introduce these major
+modernizations.
+
=item subtests
-Subtests were released in Test::More 0.94, which came with Perl 5.12.0. Subtests did not implicitly call C<done_testing()> until 0.96; the first Perl with that fix was Perl 5.14.0 with 0.98.
+Subtests were released in Test::More 0.94, which came with Perl 5.12.0.
+Subtests did not implicitly call C<done_testing()> until 0.96; the first Perl
+with that fix was Perl 5.14.0 with 0.98.
=item C<done_testing()>
-This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as part of Test::More 0.92.
+This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as
+part of Test::More 0.92.
=item C<cmp_ok()>
-Although C<cmp_ok()> was introduced in 0.40, 0.86 fixed an important bug to make it safe for overloaded objects; the fixed first shipped with Perl in 5.10.1 as part of Test::More 0.92.
+Although C<cmp_ok()> was introduced in 0.40, 0.86 fixed an important bug to
+make it safe for overloaded objects; the fixed first shipped with Perl in
+5.10.1 as part of Test::More 0.92.
=item C<new_ok()> C<note()> and C<explain()>
-These were was released in Test::More 0.82, and first shipped with Perl in 5.10.1 as part of Test::More 0.92.
+These were was released in Test::More 0.82, and first shipped with Perl in
+5.10.1 as part of Test::More 0.92.
=back
-There is a full version history in the Changes file, and the Test::More versions included as core can be found using L<Module::CoreList>:
+There is a full version history in the Changes file, and the Test::More
+versions included as core can be found using L<Module::CoreList>:
$ corelist -a Test::More
=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.
-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.
+might get a "Wide character in print" warning.
+Using C<< binmode STDOUT, ":utf8" >> will not fix it.
-One work around is to apply encodings to STDOUT and STDERR as early
-as possible and before Test::More (or any other Test module) loads.
+Use the C<tap_encoding> function to configure the TAP stream encoding.
+ use utf8;
+ use Test::Stream; # imports tap_encoding
+ use Test::More;
+ tap_encoding 'utf8';
+
+L<Test::Builder> (which powers Test::More) duplicates STDOUT and STDERR.
+So any changes to them, including changing their output disciplines,
+will not be seen by Test::More.
+
+B<Note>:deprecated ways to use utf8 or other non-ASCII characters.
+
+In the past it was necessary to alter the filehandle encoding prior to loading
+Test::More. This is no longer necessary thanks to C<tap_encoding()>.
+
+ # *** DEPRECATED WAY ***
use open ':std', ':encoding(utf8)';
use Test::More;
A more direct work around is to change the filehandles used by
L<Test::Builder>.
+ # *** EVEN MORE DEPRECATED WAY ***
my $builder = Test::More->builder;
binmode $builder->output, ":encoding(utf8)";
binmode $builder->failure_output, ":encoding(utf8)";
=item Threads
+B<NOTE:> The underlying mechanism to support threads has changed as of version
+1.301001. Instead of sharing several variables and locking them, threads now
+use the same mechanism as forking support. The new system writes events to temp
+files which are culled by the main process.
+
Test::More will only be aware of threads if C<use threads> has been done
I<before> Test::More is loaded. This is ok:
L<Test::Most> Most commonly needed test functions and features.
-=head1 AUTHORS
+=encoding utf8
+
+=head1 SOURCE
-Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
-from Joshua Pritikin's Test module and lots of help from Barrie
-Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
-the perl-qa gang.
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
-=head1 MAINTAINERS
+=head1 MAINTAINER
=over 4
=back
+=head1 AUTHORS
-=head1 BUGS
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
-See F<http://rt.cpan.org> to report and view bugs.
+=over 4
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
-=head1 SOURCE
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
-The source code repository for Test::More can be found at
-F<http://github.com/Test-More/test-more/>.
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+=item 唐鳳
+
+=back
=head1 COPYRIGHT
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
This program is free software; you can redistribute it and/or
See F<http://www.perl.com/perl/misc/Artistic.html>
-=cut
+=item Test::use::ok
-1;
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::More::DeepCheck;
+use strict;
+use warnings;
+
+use Test::Stream::ArrayBase(
+ accessors => [qw/seen/],
+);
+
+sub init {
+ $_[0]->[SEEN] ||= [{}];
+}
+
+my %PAIRS = ( '{' => '}', '[' => ']' );
+my $DNE = bless [], 'Does::Not::Exist';
+
+sub is_dne { ref $_[-1] eq ref $DNE }
+sub dne { $DNE };
+
+sub preface { "" };
+
+sub format_stack {
+ my $self = shift;
+ my $start = $self->STACK_START;
+ my $end = @$self - 1;
+
+ my @Stack = @{$self}[$start .. $end];
+
+ my @parts1 = (' $got');
+ my @parts2 = ('$expected');
+
+ my $did_arrow = 0;
+ for my $entry (@Stack) {
+ next unless $entry;
+ my $type = $entry->{type} || '';
+ my $idx = $entry->{idx};
+ my $key = $entry->{key};
+ my $wrap = $entry->{wrap};
+
+ if ($type eq 'HASH') {
+ unless ($did_arrow) {
+ push @parts1 => '->';
+ push @parts2 => '->';
+ $did_arrow++;
+ }
+ push @parts1 => "{$idx}";
+ push @parts2 => "{$idx}";
+ }
+ elsif ($type eq 'OBJECT') {
+ push @parts1 => '->';
+ push @parts2 => '->';
+ push @parts1 => "$idx()";
+ push @parts2 => "{$idx}";
+ $did_arrow = 0;
+ }
+ elsif ($type eq 'ARRAY') {
+ unless ($did_arrow) {
+ push @parts1 => '->';
+ push @parts2 => '->';
+ $did_arrow++;
+ }
+ push @parts1 => "[$idx]";
+ push @parts2 => "[$idx]";
+ }
+ elsif ($type eq 'REF') {
+ unshift @parts1 => '${';
+ unshift @parts2 => '${';
+ push @parts1 => '}';
+ push @parts2 => '}';
+ }
+
+ if ($wrap) {
+ my $pair = $PAIRS{$wrap};
+ unshift @parts1 => $wrap;
+ unshift @parts2 => $wrap;
+ push @parts1 => $pair;
+ push @parts2 => $pair;
+ }
+ }
+
+ my $error = $Stack[-1]->{error};
+ chomp($error) if $error;
+
+ my @vals = @{$Stack[-1]{vals}}[0, 1];
+ my @vars = (
+ join('', @parts1),
+ join('', @parts2),
+ );
+
+ my $out = $self->preface;
+ for my $idx (0 .. $#vals) {
+ my $val = $vals[$idx];
+ $vals[$idx] =
+ !defined $val ? 'undef'
+ : is_dne($val) ? "Does not exist"
+ : ref $val ? "$val"
+ : "'$val'";
+ }
+
+ $out .= "$vars[0] = $vals[0]\n";
+ $out .= "$vars[1] = $vals[1]\n";
+ $out .= "$error\n" if $error;
+
+ $out =~ s/^/ /msg;
+ return $out;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::More::DeepCheck - Base class or is_deeply() and mostly_like()
+implementations.
+
+=head1 DESCRIPTION
+
+This is the base class for deep check functions provided by L<Test::More> and
+L<Test::MostlyLike>. This class contains all the debugging and diagnostics
+code shared betweent he 2 tools.
+
+Most of this was refactored from the original C<is_deeply()> implementation. If
+you find any bugs or incompatabilities please report them.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::More::DeepCheck::Strict;
+use strict;
+use warnings;
+
+use Scalar::Util qw/reftype/;
+use Test::More::Tools;
+use Test::Stream::Carp qw/cluck confess/;
+use Test::Stream::Util qw/try unoverload_str is_regex/;
+
+use Test::Stream::ArrayBase(
+ accessors => [qw/stack_start/],
+ base => 'Test::More::DeepCheck',
+);
+
+sub preface { "Structures begin differing at:\n" }
+
+sub check {
+ my $class = shift;
+ my ($got, $expect) = @_;
+
+ unoverload_str(\$got, \$expect);
+ my $self = $class->new();
+
+ # neither is a reference
+ return tmt->is_eq($got, $expect)
+ if !ref $got and !ref $expect;
+
+ # one's a reference, one isn't
+ if (!ref $got xor !ref $expect) {
+ push @$self => {vals => [$got, $expect], line => __LINE__};
+ return (0, $self->format_stack);
+ }
+
+ push @$self => {vals => [$got, $expect], line => __LINE__};
+ my $ok = $self->_deep_check($got, $expect);
+ return ($ok, $ok ? () : $self->format_stack);
+}
+
+sub check_array {
+ my $class = shift;
+ my ($got, $expect) = @_;
+ my $self = $class->new();
+ push @$self => {vals => [$got, $expect], line => __LINE__};
+ my $ok = $self->_deep_check($got, $expect);
+ return ($ok, $ok ? () : $self->format_stack);
+}
+
+sub check_hash {
+ my $class = shift;
+ my ($got, $expect) = @_;
+ my $self = $class->new();
+ push @$self => {vals => [$got, $expect], line => __LINE__};
+ my $ok = $self->_deep_check($got, $expect);
+ return ($ok, $ok ? () : $self->format_stack);
+}
+
+sub check_set {
+ my $class = shift;
+ my ($got, $expect) = @_;
+
+ return 0 unless @$got == @$expect;
+
+ no warnings 'uninitialized';
+
+ # It really doesn't matter how we sort them, as long as both arrays are
+ # sorted with the same algorithm.
+ #
+ # Ensure that references are not accidentally treated the same as a
+ # string containing the reference.
+ #
+ # Have to inline the sort routine due to a threading/sort bug.
+ # See [rt.cpan.org 6782]
+ #
+ # I don't know how references would be sorted so we just don't sort
+ # them. This means eq_set doesn't really work with refs.
+ return $class->check_array(
+ [ grep( ref, @$got ), sort( grep( !ref, @$got ) ) ],
+ [ grep( ref, @$expect ), sort( grep( !ref, @$expect ) ) ],
+ );
+}
+
+sub _deep_check {
+ my $self = shift;
+ confess "XXX" unless ref $self;
+ my($e1, $e2) = @_;
+
+ unoverload_str( \$e1, \$e2 );
+
+ # Either they're both references or both not.
+ my $same_ref = !(!ref $e1 xor !ref $e2);
+ my $not_ref = (!ref $e1 and !ref $e2);
+
+ return 0 if defined $e1 xor defined $e2;
+ return 1 if !defined $e1 and !defined $e2; # Shortcut if they're both undefined.
+ return 0 if $self->is_dne($e1) xor $self->is_dne($e2);
+ return 1 if $same_ref and ($e1 eq $e2);
+
+ if ($not_ref) {
+ push @$self => {type => '', vals => [$e1, $e2], line => __LINE__};
+ return 0;
+ }
+
+ # This avoids picking up the same referenced used twice (such as
+ # [\$a, \$a]) to be considered circular.
+ my $seen = {%{$self->[SEEN]->[-1]}};
+ push @{$self->[SEEN]} => $seen;
+ my $ok = $self->_inner_check($seen, $e1, $e2);
+ pop @{$self->[SEEN]};
+ return $ok;
+}
+
+sub _inner_check {
+ my $self = shift;
+ my ($seen, $e1, $e2) = @_;
+
+ return $seen->{$e1} if $seen->{$e1} && $seen->{$e1} eq $e2;
+ $seen->{$e1} = "$e2";
+
+ my $type1 = reftype($e1) || '';
+ my $type2 = reftype($e2) || '';
+ my $diff = $type1 ne $type2;
+
+ if ($diff) {
+ push @$self => {type => 'DIFFERENT', vals => [$e1, $e2], line => __LINE__};
+ return 0;
+ }
+
+ return $self->_check_array($e1, $e2) if $type1 eq 'ARRAY';
+ return $self->_check_hash($e1, $e2) if $type1 eq 'HASH';
+
+ if ($type1 eq 'REF' || $type1 eq 'SCALAR' && !(defined(is_regex($e1)) && defined(is_regex($e2)))) {
+ push @$self => {type => 'REF', vals => [$e1, $e2], line => __LINE__};
+ my $ok = $self->_deep_check($$e1, $$e2);
+ pop @$self if $ok;
+ return $ok;
+ }
+
+ push @$self => {type => $type1, vals => [$e1, $e2], line => __LINE__};
+ return 0;
+}
+
+sub _check_array {
+ my $self = shift;
+ my ($a1, $a2) = @_;
+
+ if (grep reftype($_) ne 'ARRAY', $a1, $a2) {
+ cluck "_check_array passed a non-array ref";
+ return 0;
+ }
+
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
+ for (0 .. $max) {
+ my $e1 = $_ > $#$a1 ? $self->dne : $a1->[$_];
+ my $e2 = $_ > $#$a2 ? $self->dne : $a2->[$_];
+
+ next if $self->_check_nonrefs($e1, $e2);
+
+ push @$self => {type => 'ARRAY', idx => $_, vals => [$e1, $e2], line => __LINE__};
+ $ok = $self->_deep_check($e1, $e2);
+ pop @$self if $ok;
+
+ last unless $ok;
+ }
+
+ return $ok;
+}
+
+sub _check_nonrefs {
+ my $self = shift;
+ my($e1, $e2) = @_;
+
+ return if ref $e1 or ref $e2;
+
+ if (defined $e1) {
+ return 1 if defined $e2 and $e1 eq $e2;
+ }
+ else {
+ return 1 if !defined $e2;
+ }
+
+ return 0;
+}
+
+sub _check_hash {
+ my $self = shift;
+ my ($a1, $a2) = @_;
+
+ if (grep {(reftype($_) || '') ne 'HASH' } $a1, $a2) {
+ cluck "_check_hash passed a non-hash ref";
+ return 0;
+ }
+
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
+ for my $k (sort keys %$bigger) {
+ my $e1 = exists $a1->{$k} ? $a1->{$k} : $self->dne;
+ my $e2 = exists $a2->{$k} ? $a2->{$k} : $self->dne;
+
+ next if $self->_check_nonrefs($e1, $e2);
+
+ push @$self => {type => 'HASH', idx => $k, vals => [$e1, $e2], line => __LINE__};
+ $ok = $self->_deep_check($e1, $e2);
+ pop @$self if $ok;
+
+ last unless $ok;
+ }
+
+ return $ok;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::More::DeepCheck::Strict - Where is_deeply() is implemented.
+
+=head1 DESCRIPTION
+
+This is the package where the code for C<is_deeply()> from L<Test::More> lives.
+This code was refactored into this form, but should remain 100% compatible with
+the old implementation. If you find an incompatability please report it.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::More::DeepCheck::Tolerant;
+use strict;
+use warnings;
+
+use Test::More::Tools;
+use Scalar::Util qw/reftype blessed/;
+use Test::Stream::Util qw/try unoverload_str is_regex/;
+
+use Test::Stream::ArrayBase(
+ accessors => [qw/stack_start/],
+ base => 'Test::More::DeepCheck',
+);
+
+sub preface { "First mismatch:\n" };
+
+sub check {
+ my $class = shift;
+ my ($got, $expect) = @_;
+
+ unoverload_str(\$got, \$expect);
+ my $self = $class->new();
+
+ # neither is a reference
+ return tmt->is_eq($got, $expect)
+ if !ref $got and !ref $expect;
+
+ push @$self => {type => '', vals => [$got, $expect], line => __LINE__};
+ my $ok = $self->_deep_check($got, $expect);
+ return ($ok, $ok ? () : $self->format_stack);
+}
+
+#============================
+
+sub _reftype {
+ my ($thing) = @_;
+ my $type = reftype $thing || return '';
+
+ $type = uc($type);
+
+ return $type unless $type eq 'SCALAR';
+
+ $type = 'REGEXP' if $type eq 'REGEX' || defined is_regex($thing);
+
+ return $type;
+}
+
+sub _nonref_check {
+ my ($self) = shift;
+ my ($got, $expect) = @_;
+
+ my $numeric = $got !~ m/\D/i && $expect !~ m/\D/i;
+ return $numeric ? $got == $expect : "$got" eq "$expect";
+}
+
+sub _deep_check {
+ my ($self) = shift;
+ my ($got, $expect) = @_;
+
+ return 1 unless defined($got) || defined($expect);
+ return 0 if defined($got) xor defined($expect);
+
+ my $seen = $self->[SEEN]->[-1];
+ return 1 if $seen->{$got} && $seen->{$got} eq $expect;
+ $seen->{$got} = "$expect";
+
+ my $etype = _reftype $expect;
+ my $gtype = _reftype $got;
+
+ return 0 if ($etype && $etype ne 'REGEXP' && !$gtype) || ($gtype && !$etype);
+
+ return $self->_nonref_check($got, $expect) unless $etype;
+
+ ##### Both are refs at this point ####
+ return 1 if $gtype && $got == $expect;
+
+ if ($etype eq 'REGEXP') {
+ return "$got" eq "$expect" if $gtype eq 'REGEXP'; # Identical regexp check
+ return $got =~ $expect;
+ }
+
+ my $ok = 0;
+ $seen = {%$seen};
+ push @{$self->[SEEN]} => $seen;
+ if ($etype eq 'ARRAY') {
+ $ok = $self->_array_check($got, $expect);
+ }
+ elsif ($etype eq 'HASH') {
+ $ok = $self->_hash_check($got, $expect);
+ }
+ pop @{$self->[SEEN]};
+
+ return $ok;
+}
+
+sub _array_check {
+ my $self = shift;
+ my ($got, $expect) = @_;
+
+ return 0 if _reftype($got) ne 'ARRAY';
+
+ for (my $i = 0; $i < @$expect; $i++) {
+ push @$self => {type => 'ARRAY', idx => $i, vals => [$got->[$i], $expect->[$i]], line => __LINE__};
+ $self->_deep_check($got->[$i], $expect->[$i]) || return 0;
+ pop @$self;
+ }
+
+ return 1;
+}
+
+sub _hash_check {
+ my $self = shift;
+ my ($got, $expect) = @_;
+
+ my $blessed = blessed($got);
+ my $hashref = _reftype($got) eq 'HASH';
+ my $arrayref = _reftype($got) eq 'ARRAY';
+
+ for my $key (sort keys %$expect) {
+ # $wrap $direct $field Leftover from wrap
+ my ($wrap, $direct, $field) = ($key =~ m/^ ([\[\{]?) (:?) ([^\]]*) [\]\}]?$/x);
+
+ if ($wrap) {
+ if (!$blessed) {
+ push @$self => {
+ type => 'OBJECT',
+ idx => $field,
+ wrap => $wrap,
+ vals => ["(EXCEPTION)", $expect->{$key}],
+ error => "Cannot call method '$field' on an unblessed reference.\n",
+ line => __LINE__,
+ };
+ return 0;
+ }
+ if ($direct) {
+ push @$self => {
+ type => 'OBJECT',
+ idx => $field,
+ wrap => $wrap,
+ vals => ['(EXCEPTION)', $expect->{$key}],
+ error => "'$key' is invalid, cannot wrap($wrap) a direct-access($direct).\n",
+ line => __LINE__,
+ };
+ return 0;
+ }
+ }
+
+ my ($val, $type);
+ if ($direct || !$blessed) {
+ if ($arrayref) {
+ $type = 'ARRAY';
+ if ($field !~ m/^-?\d+$/i) {
+ push @$self => {
+ type => 'ARRAY',
+ idx => $field,
+ vals => ['(EXCEPTION)', $expect->{$key}],
+ error => "'$field' is not a valid array index\n",
+ line => __LINE__,
+ };
+ return 0;
+ }
+
+ # Try, if they specify -1 in an empty array it may throw an exception
+ my ($success, $error) = try { $val = $got->[$field] };
+ if (!$success) {
+ push @$self => {
+ type => 'ARRAY',
+ idx => $field,
+ vals => ['(EXCEPTION)', $expect->{$key}],
+ error => $error,
+ line => __LINE__,
+ };
+ return 0;
+ }
+ }
+ else {
+ $type = 'HASH';
+ $val = $got->{$field};
+ }
+ }
+ else {
+ $type = 'OBJECT';
+ my ($success, $error) = try {
+ if ($wrap) {
+ if ($wrap eq '[') {
+ $val = [$got->$field()];
+ }
+ elsif ($wrap eq '{') {
+ $val = {$got->$field()};
+ }
+ else {
+ die "'$wrap' is not a valid way to wrap a method call";
+ }
+ }
+ else {
+ $val = $got->$field();
+ }
+ };
+ if (!$success) {
+ push @$self => {
+ type => 'OBJECT',
+ idx => $field,
+ wrap => $wrap || undef,
+ vals => ['(EXCEPTION)', $expect->{$key}],
+ error => $error,
+ line => __LINE__,
+ };
+ return 0;
+ }
+ }
+
+ push @$self => {type => $type, idx => $field, vals => [$val, $expect->{$key}], line => __LINE__, wrap => $wrap || undef};
+ $self->_deep_check($val, $expect->{$key}) || return 0;
+ pop @$self;
+ }
+
+ return 1;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::More::DeepCheck::Tolerant - Under the hood implementation of
+mostly_like()
+
+=head1 DESCRIPTION
+
+This is where L<Test::MostlyLike> is implemented.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::More::Tools;
+use strict;
+use warnings;
+
+use Test::Stream::Context;
+
+use Test::Stream::Exporter;
+default_exports qw/tmt/;
+Test::Stream::Exporter->cleanup;
+
+use Test::Stream::Util qw/try protect is_regex unoverload_str unoverload_num/;
+use Scalar::Util qw/blessed reftype/;
+
+sub tmt() { __PACKAGE__ }
+
+# Bad, these are not comparison operators. Should we include more?
+my %CMP_OK_BL = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "...");
+my %NUMERIC_CMPS = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
+
+sub cmp_check {
+ my($class, $got, $type, $expect) = @_;
+
+ my $ctx = context();
+ my $name = $ctx->subname;
+ $name =~ s/^.*:://g;
+ $name = 'cmp_check' if $name eq '__ANON__';
+ $ctx->throw("$type is not a valid comparison operator in $name\()")
+ if $CMP_OK_BL{$type};
+
+ my ($p, $file, $line) = $ctx->call;
+
+ my $test = 0;
+ my ($success, $error) = try {
+ # This is so that warnings come out at the caller's level
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
+ eval qq[
+#line $line "(eval in $name) $file"
+\$test = (\$got $type \$expect);
+1;
+ ] || die $@;
+ };
+
+ my @diag;
+ push @diag => <<" END" unless $success;
+An error occurred while using $type:
+------------------------------------
+$error
+------------------------------------
+ END
+
+ unless($test) {
+ # Treat overloaded objects as numbers if we're asked to do a
+ # numeric comparison.
+ my $unoverload = $NUMERIC_CMPS{$type}
+ ? \&unoverload_num
+ : \&unoverload_str;
+
+ $unoverload->(\$got, \$expect);
+
+ if( $type =~ /^(eq|==)$/ ) {
+ push @diag => $class->_is_diag( $got, $type, $expect );
+ }
+ elsif( $type =~ /^(ne|!=)$/ ) {
+ push @diag => $class->_isnt_diag( $got, $type );
+ }
+ else {
+ push @diag => $class->_cmp_diag( $got, $type, $expect );
+ }
+ }
+
+ return($test, @diag);
+}
+
+sub is_eq {
+ my($class, $got, $expect) = @_;
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+ return ($test, $test ? () : $class->_is_diag($got, 'eq', $expect));
+ }
+
+ return $class->cmp_check($got, 'eq', $expect);
+}
+
+sub is_num {
+ my($class, $got, $expect) = @_;
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+ return ($test, $test ? () : $class->_is_diag($got, '==', $expect));
+ }
+
+ return $class->cmp_check($got, '==', $expect);
+}
+
+sub isnt_eq {
+ my($class, $got, $dont_expect) = @_;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+ return ($test, $test ? () : $class->_isnt_diag($got, 'ne'));
+ }
+
+ return $class->cmp_check($got, 'ne', $dont_expect);
+}
+
+sub isnt_num {
+ my($class, $got, $dont_expect) = @_;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+ return ($test, $test ? () : $class->_isnt_diag($got, '!='));
+ }
+
+ return $class->cmp_check($got, '!=', $dont_expect);
+}
+
+sub regex_check {
+ my($class, $thing, $got_regex, $cmp) = @_;
+
+ my $regex = is_regex($got_regex);
+ return (0, " '$got_regex' doesn't look much like a regex to me.")
+ unless defined $regex;
+
+ my $ctx = context();
+ my ($p, $file, $line) = $ctx->call;
+
+ my $test;
+ my $mock = qq{#line $line "$file"\n};
+
+ my @warnings;
+ my ($success, $error) = try {
+ # No point in issuing an uninit warning, they'll see it in the diagnostics
+ no warnings 'uninitialized';
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
+ protect { eval $mock . q{$test = $thing =~ /$regex/ ? 1 : 0; 1} || die $@ };
+ };
+
+ return (0, "Exception: $error") unless $success;
+
+ my $negate = $cmp eq '!~';
+
+ $test = !$test if $negate;
+
+ unless($test) {
+ $thing = defined $thing ? "'$thing'" : 'undef';
+ my $match = $negate ? "matches" : "doesn't match";
+ my $diag = sprintf(qq{ \%s\n \%13s '\%s'\n}, $thing, $match, $got_regex);
+ return (0, $diag);
+ }
+
+ return (1);
+}
+
+sub can_check {
+ my ($us, $proto, $class, @methods) = @_;
+
+ my @diag;
+ for my $method (@methods) {
+ my $ok;
+ my ($success, $error) = try { $ok = $proto->can($method) };
+ if ($success) {
+ push @diag => " $class\->can('$method') failed" unless $ok;
+ }
+ else {
+ my $file = __FILE__;
+ $error =~ s/ at \Q$file\E line \d+//;
+ push @diag => " $class\->can('$method') failed with an exception:\n $error";
+ }
+ }
+
+ return (!@diag, @diag)
+}
+
+sub isa_check {
+ my($us, $thing, $class, $thing_name) = @_;
+
+ my ($whatami, $try_isa, $diag, $type);
+ if( !defined $thing ) {
+ $whatami = 'undef';
+ $$thing_name = "undef" unless defined $$thing_name;
+ $diag = defined $thing ? "$$thing_name isn't a '$class'" : "$$thing_name isn't defined";
+ }
+ elsif($type = blessed $thing) {
+ $whatami = 'object';
+ $try_isa = 1;
+ $$thing_name = "An object of class '$type'" unless defined $$thing_name;
+ $diag = "$$thing_name isn't a '$class'";
+ }
+ elsif($type = ref $thing) {
+ $whatami = 'reference';
+ $$thing_name = "A reference of type '$type'" unless defined $$thing_name;
+ $diag = "$$thing_name isn't a '$class'";
+ }
+ else {
+ $whatami = 'class';
+ $try_isa = $thing && $thing !~ m/^\d+$/;
+ $$thing_name = "The class (or class-like) '$thing'" unless defined $$thing_name;
+ $diag = "$$thing_name isn't a '$class'";
+ }
+
+ my $ok;
+ if ($try_isa) {
+ # We can't use UNIVERSAL::isa because we want to honor isa() overrides
+ my ($success, $error) = try {
+ my $ctx = context();
+ my ($p, $f, $l) = $ctx->call;
+ eval qq{#line $l "$f"\n\$ok = \$thing\->isa(\$class); 1} || die $@;
+ };
+
+ die <<" WHOA" unless $success;
+WHOA! I tried to call ->isa on your $whatami and got some weird error.
+Here's the error.
+$error
+ WHOA
+ }
+ else {
+ # Special case for isa_ok( [], "ARRAY" ) and like
+ $ok = UNIVERSAL::isa($thing, $class);
+ }
+
+ return ($ok) if $ok;
+ return ($ok, " $diag\n");
+}
+
+sub new_check {
+ my($us, $class, $args, $object_name) = @_;
+
+ $args ||= [];
+
+ my $obj;
+ my($success, $error) = try {
+ my $ctx = context();
+ my ($p, $f, $l) = $ctx->call;
+ eval qq{#line $l "$f"\n\$obj = \$class\->new(\@\$args); 1} || die $@;
+ };
+ if($success) {
+ $object_name = "'$object_name'" if $object_name;
+ my ($ok, @diag) = $us->isa_check($obj, $class, \$object_name);
+ my $name = "$object_name isa '$class'";
+ return ($obj, $name, $ok, @diag);
+ }
+ else {
+ $class = 'undef' unless defined $class;
+ return (undef, "$class->new() died", 0, " Error was: $error");
+ }
+}
+
+sub explain {
+ my ($us, @args) = @_;
+ protect { require Data::Dumper };
+
+ return map {
+ ref $_
+ ? do {
+ my $dumper = Data::Dumper->new( [$_] );
+ $dumper->Indent(1)->Terse(1);
+ $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
+ $dumper->Dump;
+ }
+ : $_
+ } @args;
+}
+
+sub _diag_fmt {
+ my( $class, $type, $val ) = @_;
+
+ if( defined $$val ) {
+ if( $type eq 'eq' or $type eq 'ne' ) {
+ # quote and force string context
+ $$val = "'$$val'";
+ }
+ else {
+ # force numeric context
+ unoverload_num($val);
+ }
+ }
+ else {
+ $$val = 'undef';
+ }
+
+ return;
+}
+
+sub _is_diag {
+ my( $class, $got, $type, $expect ) = @_;
+
+ $class->_diag_fmt( $type, $_ ) for \$got, \$expect;
+
+ return <<"DIAGNOSTIC";
+ got: $got
+ expected: $expect
+DIAGNOSTIC
+}
+
+sub _isnt_diag {
+ my( $class, $got, $type ) = @_;
+
+ $class->_diag_fmt( $type, \$got );
+
+ return <<"DIAGNOSTIC";
+ got: $got
+ expected: anything else
+DIAGNOSTIC
+}
+
+
+sub _cmp_diag {
+ my( $class, $got, $type, $expect ) = @_;
+
+ $got = defined $got ? "'$got'" : 'undef';
+ $expect = defined $expect ? "'$expect'" : 'undef';
+
+ return <<"DIAGNOSTIC";
+ $got
+ $type
+ $expect
+DIAGNOSTIC
+}
+
+sub subtest {
+ my ($class, $name, $code, @args) = @_;
+
+ my $ctx = context();
+
+ $ctx->throw("subtest()'s second argument must be a code ref")
+ unless $code && 'CODE' eq reftype($code);
+
+ $ctx->child('push', $name);
+ $ctx->clear;
+ my $todo = $ctx->hide_todo;
+
+ my ($succ, $err) = try {
+ {
+ no warnings 'once';
+ local $Test::Builder::Level = 1;
+ $code->(@args);
+ }
+
+ $ctx->set;
+ my $stream = $ctx->stream;
+ $ctx->done_testing unless $stream->plan || $stream->ended;
+
+ require Test::Stream::ExitMagic;
+ {
+ local $? = 0;
+ Test::Stream::ExitMagic->new->do_magic($stream, $ctx->snapshot);
+ }
+ };
+
+ $ctx->set;
+ $ctx->restore_todo($todo);
+ # This sends the subtest event
+ my $st = $ctx->child('pop', $name);
+
+ unless ($succ) {
+ die $err unless blessed($err) && $err->isa('Test::Stream::Event');
+ $ctx->bail($err->reason) if $err->isa('Test::Stream::Event::Bail');
+ }
+
+ return $st->bool;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::More::Tools - Generic form of tools from Test::More.
+
+=head1 DESCRIPTION
+
+People used to call L<Test::More> tools within other testing tools. This mostly
+works, but it generates events for each call. This package gives you access to
+the implementations directly, without generating events for you. This allows
+you to create a composite tool without generating extra events.
+
+=head1 SYNOPSYS
+
+ use Test::More::Tools qw/tmt/;
+ use Test::Stream::Toolset qw/context/;
+
+ # This is how Test::More::is is implemented
+ sub my_is {
+ my ($got, $want, $name) = @_;
+
+ my $ctx = context;
+
+ my ($ok, @diag) = tmt->is_eq($got, $want);
+
+ $ctx->ok($ok, $name, \@diag);
+ }
+
+=head1 EXPORTS
+
+=over 4
+
+=item $pkg = tmt()
+
+Simply returns the string 'Test::More::Tools';
+
+=back
+
+=head1 CLASS METHODS
+
+Not all methods are listed. The ones that have been omitted are not intuitive,
+and probably should not be used at all.
+
+=over 4
+
+=item ($bool, @diag) = tmt->cmp_check($got, $op, $want)
+
+Check 2 values using the operator specified example: C<$got == $want>
+
+=item ($bool, @diag) = tmt->is_eq($got, $want)
+
+String compare.
+
+=item ($bool, @diag) = tmt->is_num($got, $want)
+
+Numeric compare.
+
+=item ($bool, @diag) = tmt->isnt_eq($got, $dont_want)
+
+String inequality compare.
+
+=item ($bool, @diag) = tmt->isnt_num($got, $dont_want)
+
+Numeric inequality compare.
+
+=item ($bool, @diag) = tmt->regex_check($got, $regex, $op)
+
+Regex compare. C<$op> may be C<=~> or C<!~>.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::MostlyLike;
+use strict;
+use warnings;
+
+use Test::Stream::Toolset;
+use Test::Stream::Exporter;
+default_exports qw/mostly_like/;
+Test::Stream::Exporter->cleanup;
+
+use Test::More::DeepCheck::Tolerant;
+
+sub mostly_like {
+ my ($got, $want, $name) = @_;
+
+ my $ctx = context();
+
+ unless( @_ == 2 or @_ == 3 ) {
+ my $msg = <<'WARNING';
+mostly_like() takes two or three args, you gave %d.
+This usually means you passed an array or hash instead
+of a reference to it
+WARNING
+ chop $msg; # clip off newline so carp() will put in line/file
+
+ $ctx->alert(sprintf $msg, scalar @_);
+
+ $ctx->ok(0, undef, ['incorrect number of args']);
+ return 0;
+ }
+
+ my ($ok, @diag) = Test::More::DeepCheck::Tolerant->check($got, $want);
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::MostlyLike - Relaxed checking of deep data structures.
+
+=head1 SYNOPSYS
+
+ my $got = [qw/foo bar baz/];
+
+ mostly_like(
+ $got,
+ ['foo', qr/a/],
+ "Deeply nested structure matches (mostly)"
+ );
+
+=head1 DESCRIPTION
+
+A tool based on C<is_deeply> from L<Test::More>. This tool produces nearly
+identical diagnostics. This tool gives you extra control by letting you check
+only the parts of the structure you care about, ignoring the rest.
+
+=head1 EXPORTS
+
+=over 4
+
+=item $bool = mostly_like($got, $expect, $name)
+
+Generates a single ok event with diagnostics to help you find any failures.
+
+Got should be the data structure you want to test. $expect should be a data
+structure representing what you expect to see. Unlike C<is_deeply> any keys in
+C<$got> that do not I<exist> in C<$expect> will be ignored.
+
+=back
+
+=head1 WHAT TO EXPECT
+
+When an a blessed object is encountered in the C<$got> structure, any fields
+listed in C<$expect> will be called as methods on the C<$got> object. See the
+object/direct element access section below for bypassing this.
+
+Any keys or attributes in C<$got> will be ignored unless the also I<exist> in C<$expect>
+
+=head1 IGNORING THINGS YOU DO NOT CARE ABOUT
+
+ my $got = { foo => 1, bar => 2 };
+ my $expect = { foo => 1 };
+
+ mostly_like($got, $expect, "Ignores 'bar'");
+
+If you want to check that a value is not set:
+
+ my $got = { foo => 1, bar => 2 };
+ my $expect = { foo => 1, bar => undef };
+
+ mostly_like($got, $expect, "Will fail since 'bar' has a value");
+
+=head2 EXACT MATCHES
+
+ my $got = 'foo';
+ my $expect = 'foo';
+ mostly_like($got, $expect, "Check a value directly");
+
+Also works for deeply nested structures
+
+ mostly_like(
+ [
+ {stuff => 'foo bar baz'},
+ ],
+ [
+ {stuff => 'foo bar baz'},
+ ],
+ "Check a value directly, nested"
+ );
+
+=head2 REGEX MATCHES
+
+ my $got = 'foo bar baz';
+ my $expect = qr/bar/;
+ mostly_like($got, $expect, 'Match');
+
+Works nested as well:
+
+ mostly_like(
+ [
+ {stuff => 'foo bar baz'},
+ ],
+ [
+ {stuff => qr/bar/},
+ ],
+ "Check a value directly, nested"
+ );
+
+=head2 ARRAY ELEMENT MATCHES
+
+ my $got = [qw/foo bar baz/];
+ my $exp = [qw/foo bar/];
+
+ mostly_like($got, $exp, "Ignores unspecified indexes");
+
+You can also just check specific indexes:
+
+ my $got = [qw/foo bar baz/];
+ my $exp = { ':1' => 'bar' };
+
+ mostly_like($got, $exp, "Only checks array index 1");
+
+When doing this the index must always be prefixed with ':'.
+
+=head2 HASH ELEMENT MATCHES
+
+ my $got = { foo => 1, bar => 2 };
+ my $exp = { foo => 1 };
+
+ mostly_like($got, $exp, "Only checks foo");
+
+=head2 OBJECT METHOD MATCHES
+
+=head3 UNALTERED
+
+ sub foo { $_[0]->{foo} }
+
+ my $got = bless {foo => 1}, __PACKAGE__;
+ my $exp = { foo => 1 };
+
+ mostly_like($got, $exp, 'Checks the return of $got->foo()');
+
+=head3 WRAPPED
+
+Sometimes methods return lists, in such cases you can wrap them in arrayrefs or
+hashrefs:
+
+ sub list { qw/foo bar baz/ }
+ sub dict { foo => 0, bar => 1, baz => 2 }
+
+ my $got = bless {}, __PACKAGE__;
+ my $exp = {
+ '[list]' => [ qw/foo bar baz/ ],
+ '[dict]' => { foo => 0, bar => 1, baz => 2 },
+ };
+ mostly_like($got, $exp, "Wrapped the method calls");
+
+=head3 DIRECT ELEMENT ACCESS
+
+Sometimes you want to ignore the methods and get the hash value directly.
+
+ sub foo { die "do not call me" }
+
+ my $got = bless { foo => 'secret' }, __PACKAGE__;
+ my $exp = { ':foo' => 'secret' };
+
+ mostly_like($got, $exp, "Did not call the fatal method");
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+=item Test::MostlyLike
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
package Test::Simple;
-use 5.006;
+use 5.008001;
use strict;
+use warnings;
-our $VERSION = '1.001008';
+our $VERSION = '1.301001_075';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-use Test::Builder::Module 0.99;
-our @ISA = qw(Test::Builder::Module);
-our @EXPORT = qw(ok);
+use Test::Stream 1.301001_075 '-internal';
+use Test::Stream::Toolset;
+
+use Test::Stream::Exporter;
+default_exports qw/ok/;
+Test::Stream::Exporter->cleanup;
+
+sub before_import {
+ my $class = shift;
+ my ($importer, $list) = @_;
+
+ my $meta = init_tester($importer);
+ my $context = context(1);
+ my $idx = 0;
+ my $other = [];
+ while ($idx <= $#{$list}) {
+ my $item = $list->[$idx++];
+
+ if (defined $item and $item eq 'no_diag') {
+ Test::Stream->shared->set_no_diag(1);
+ }
+ elsif ($item eq 'tests') {
+ $context->plan($list->[$idx++]);
+ }
+ elsif ($item eq 'skip_all') {
+ $context->plan(0, 'SKIP', $list->[$idx++]);
+ }
+ elsif ($item eq 'no_plan') {
+ $context->plan(0, 'NO PLAN');
+ }
+ elsif ($item eq 'import') {
+ push @$other => @{$list->[$idx++]};
+ }
+ else {
+ $context->throw("Unknown option: $item");
+ }
+ }
+
+ @$list = @$other;
+
+ return;
+}
+
+sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes)
+ my $ctx = context();
+ return $ctx->ok(@_);
+ return $_[0] ? 1 : 0;
+}
-my $CLASS = __PACKAGE__;
+1;
+
+__END__
=head1 NAME
ok( $foo eq $bar, 'foo is bar' );
-
=head1 DESCRIPTION
** If you are unfamiliar with testing B<read L<Test::Tutorial> first!> **
will do what you mean (fail if stuff is empty)
-=cut
-
-sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes)
- return $CLASS->builder->ok(@_);
-}
-
=back
Test::Simple will start by printing number of tests run in the form
Look in L<Test::More>'s SEE ALSO for more testing modules.
-=head1 AUTHORS
+=encoding utf8
-Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
-E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
-=head1 MAINTAINERS
+=head1 MAINTAINER
=over 4
=back
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
=head1 COPYRIGHT
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
-This program is free software; you can redistribute it and/or
+This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://www.perl.com/perl/misc/Artistic.html>
-=cut
+=item Test::use::ok
-1;
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream;
+use strict;
+use warnings;
+
+our $VERSION = '1.301001_075';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+use Test::Stream::Context qw/context/;
+use Test::Stream::Threads;
+use Test::Stream::IOSets;
+use Test::Stream::Util qw/try/;
+use Test::Stream::Carp qw/croak confess carp/;
+use Test::Stream::Meta qw/MODERN ENCODING init_tester/;
+
+use Test::Stream::ArrayBase(
+ accessors => [qw{
+ no_ending no_diag no_header
+ pid tid
+ state
+ subtests subtest_todo subtest_exception
+ subtest_tap_instant
+ subtest_tap_delayed
+ mungers
+ listeners
+ follow_ups
+ bailed_out
+ exit_on_disruption
+ use_tap use_legacy _use_fork
+ use_numbers
+ io_sets
+ event_id
+ in_subthread
+ }],
+);
+
+sub STATE_COUNT() { 0 }
+sub STATE_FAILED() { 1 }
+sub STATE_PLAN() { 2 }
+sub STATE_PASSING() { 3 }
+sub STATE_LEGACY() { 4 }
+sub STATE_ENDED() { 5 }
+
+sub OUT_STD() { 0 }
+sub OUT_ERR() { 1 }
+sub OUT_TODO() { 2 }
+
+use Test::Stream::Exporter;
+exports qw/
+ OUT_STD OUT_ERR OUT_TODO
+ STATE_COUNT STATE_FAILED STATE_PLAN STATE_PASSING STATE_LEGACY STATE_ENDED
+/;
+default_exports qw/ cull tap_encoding context /;
+Test::Stream::Exporter->cleanup;
+
+sub tap_encoding {
+ my ($encoding) = @_;
+
+ require Encode;
+
+ croak "encoding '$encoding' is not valid, or not available"
+ unless $encoding eq 'legacy' || Encode::find_encoding($encoding);
+
+ require Test::Stream::Context;
+ my $ctx = Test::Stream::Context::context();
+ $ctx->stream->io_sets->init_encoding($encoding);
+
+ my $meta = init_tester($ctx->package);
+ $meta->[ENCODING] = $encoding;
+}
+
+sub cull {
+ my $ctx = Test::Stream::Context::context();
+ $ctx->stream->fork_cull();
+}
+
+sub before_import {
+ my $class = shift;
+ my ($importer, $list) = @_;
+
+ if (@$list && $list->[0] eq '-internal') {
+ shift @$list;
+ return;
+ }
+
+ my $meta = init_tester($importer);
+ $meta->[MODERN] = 1;
+
+ my $other = [];
+ my $idx = 0;
+ my $stream = $class->shared;
+
+ while ($idx <= $#{$list}) {
+ my $item = $list->[$idx++];
+ next unless $item;
+
+ if ($item eq 'subtest_tap') {
+ my $val = $list->[$idx++];
+ if (!$val || $val eq 'none') {
+ $stream->set_subtest_tap_instant(0);
+ $stream->set_subtest_tap_delayed(0);
+ }
+ elsif ($val eq 'instant') {
+ $stream->set_subtest_tap_instant(1);
+ $stream->set_subtest_tap_delayed(0);
+ }
+ elsif ($val eq 'delayed') {
+ $stream->set_subtest_tap_instant(0);
+ $stream->set_subtest_tap_delayed(1);
+ }
+ elsif ($val eq 'both') {
+ $stream->set_subtest_tap_instant(1);
+ $stream->set_subtest_tap_delayed(1);
+ }
+ else {
+ croak "'$val' is not a valid option for '$item'";
+ }
+ }
+ elsif ($item eq 'utf8') {
+ $stream->io_sets->init_encoding('utf8');
+ $meta->[ENCODING] = 'utf8';
+ }
+ elsif ($item eq 'encoding') {
+ my $encoding = $list->[$idx++];
+
+ croak "encoding '$encoding' is not valid, or not available"
+ unless Encode::find_encoding($encoding);
+
+ $stream->io_sets->init_encoding($encoding);
+ $meta->[ENCODING] = $encoding;
+ }
+ elsif ($item eq 'enable_fork') {
+ $stream->use_fork;
+ }
+ else {
+ push @$other => $item;
+ }
+ }
+
+ @$list = @$other;
+
+ return;
+}
+
+sub plan { $_[0]->[STATE]->[-1]->[STATE_PLAN] }
+sub count { $_[0]->[STATE]->[-1]->[STATE_COUNT] }
+sub failed { $_[0]->[STATE]->[-1]->[STATE_FAILED] }
+sub ended { $_[0]->[STATE]->[-1]->[STATE_ENDED] }
+sub legacy { $_[0]->[STATE]->[-1]->[STATE_LEGACY] }
+
+sub is_passing {
+ my $self = shift;
+
+ if (@_) {
+ ($self->[STATE]->[-1]->[STATE_PASSING]) = @_;
+ }
+
+ my $current = $self->[STATE]->[-1]->[STATE_PASSING];
+
+ my $plan = $self->[STATE]->[-1]->[STATE_PLAN];
+ return $current if $self->[STATE]->[-1]->[STATE_ENDED];
+ return $current unless $plan;
+ return $current unless $plan->max;
+ return $current if $plan->directive && $plan->directive eq 'NO PLAN';
+ return $current unless $self->[STATE]->[-1]->[STATE_COUNT] > $plan->max;
+
+ return $self->[STATE]->[-1]->[STATE_PASSING] = 0;
+}
+
+sub init {
+ my $self = shift;
+
+ $self->[PID] = $$;
+ $self->[TID] = get_tid();
+ $self->[STATE] = [[0, 0, undef, 1]];
+ $self->[USE_TAP] = 1;
+ $self->[USE_NUMBERS] = 1;
+ $self->[IO_SETS] = Test::Stream::IOSets->new;
+ $self->[EVENT_ID] = 1;
+ $self->[NO_ENDING] = 1;
+ $self->[SUBTESTS] = [];
+
+ $self->[SUBTEST_TAP_INSTANT] = 1;
+ $self->[SUBTEST_TAP_DELAYED] = 0;
+
+ $self->use_fork if USE_THREADS;
+
+ $self->[EXIT_ON_DISRUPTION] = 1;
+}
+
+{
+ my ($root, @stack, $magic);
+
+ END {
+ $root->fork_cull if $root && $root->_use_fork && $$ == $root->[PID];
+ $magic->do_magic($root) if $magic && $root && !$root->[NO_ENDING]
+ }
+
+ sub _stack { @stack }
+
+ sub shared {
+ my ($class) = @_;
+ return $stack[-1] if @stack;
+
+ @stack = ($root = $class->new(0));
+ $root->[NO_ENDING] = 0;
+
+ require Test::Stream::Context;
+ require Test::Stream::Event::Finish;
+ require Test::Stream::ExitMagic;
+ require Test::Stream::ExitMagic::Context;
+
+ $magic = Test::Stream::ExitMagic->new;
+
+ return $root;
+ }
+
+ sub clear {
+ $root->[NO_ENDING] = 1;
+ $root = undef;
+ $magic = undef;
+ @stack = ();
+ }
+
+ sub intercept_start {
+ my $class = shift;
+ my ($new) = @_;
+
+ my $old = $stack[-1];
+
+ unless($new) {
+ $new = $class->new();
+
+ $new->set_exit_on_disruption(0);
+ $new->set_use_tap(0);
+ $new->set_use_legacy(0);
+ }
+
+ push @stack => $new;
+
+ return ($new, $old);
+ }
+
+ sub intercept_stop {
+ my $class = shift;
+ my ($current) = @_;
+ croak "Stream stack inconsistency" unless $current == $stack[-1];
+ pop @stack;
+ }
+}
+
+sub intercept {
+ my $class = shift;
+ my ($code) = @_;
+
+ croak "The first argument to intercept must be a coderef"
+ unless $code && ref $code && ref $code eq 'CODE';
+
+ my ($new, $old) = $class->intercept_start();
+ my ($ok, $error) = try { $code->($new, $old) };
+ $class->intercept_stop($new);
+
+ die $error unless $ok;
+ return $ok;
+}
+
+sub listen {
+ my $self = shift;
+ for my $sub (@_) {
+ next unless $sub;
+
+ croak "listen only takes coderefs for arguments, got '$sub'"
+ unless ref $sub && ref $sub eq 'CODE';
+
+ push @{$self->[LISTENERS]} => $sub;
+ }
+}
+
+sub munge {
+ my $self = shift;
+ for my $sub (@_) {
+ next unless $sub;
+
+ croak "munge only takes coderefs for arguments, got '$sub'"
+ unless ref $sub && ref $sub eq 'CODE';
+
+ push @{$self->[MUNGERS]} => $sub;
+ }
+}
+
+sub follow_up {
+ my $self = shift;
+ for my $sub (@_) {
+ next unless $sub;
+
+ croak "follow_up only takes coderefs for arguments, got '$sub'"
+ unless ref $sub && ref $sub eq 'CODE';
+
+ push @{$self->[FOLLOW_UPS]} => $sub;
+ }
+}
+
+sub use_fork {
+ require File::Temp;
+ require Storable;
+
+ $_[0]->[_USE_FORK] ||= File::Temp::tempdir(CLEANUP => 0);
+ confess "Could not get a temp dir" unless $_[0]->[_USE_FORK];
+ if ($^O eq 'VMS') {
+ require VMS::Filespec;
+ $_[0]->[_USE_FORK] = VMS::Filespec::unixify($_[0]->[_USE_FORK]);
+ }
+ return 1;
+}
+
+sub fork_out {
+ my $self = shift;
+
+ my $tempdir = $self->[_USE_FORK];
+ confess "Fork support has not been turned on!" unless $tempdir;
+
+ my $tid = get_tid();
+
+ for my $event (@_) {
+ next unless $event;
+ next if $event->isa('Test::Stream::Event::Finish');
+
+ # First write the file, then rename it so that it is not read before it is ready.
+ my $name = $tempdir . "/$$-$tid-" . ($self->[EVENT_ID]++);
+ my ($ret, $err) = try { Storable::store($event, $name) };
+ # Temporary to debug an error on one cpan-testers box
+ unless ($ret) {
+ require Data::Dumper;
+ confess(Data::Dumper::Dumper({ error => $err, event => $event}));
+ }
+ rename($name, "$name.ready") || confess "Could not rename file '$name' -> '$name.ready'";
+ }
+}
+
+sub fork_cull {
+ my $self = shift;
+
+ confess "fork_cull() can only be called from the parent process!"
+ if $$ != $self->[PID];
+
+ confess "fork_cull() can only be called from the parent thread!"
+ if get_tid() != $self->[TID];
+
+ my $tempdir = $self->[_USE_FORK];
+ confess "Fork support has not been turned on!" unless $tempdir;
+
+ opendir(my $dh, $tempdir) || croak "could not open temp dir ($tempdir)!";
+
+ my @files = sort readdir($dh);
+ for my $file (@files) {
+ next if $file =~ m/^\.+$/;
+ next unless $file =~ m/\.ready$/;
+
+ # Untaint the path.
+ my $full = "$tempdir/$file";
+ ($full) = ($full =~ m/^(.*)$/gs);
+
+ my $obj = Storable::retrieve($full);
+ confess "Empty event object found '$full'" unless $obj;
+
+ if ($ENV{TEST_KEEP_TMP_DIR}) {
+ rename($full, "$full.complete")
+ || confess "Could not rename file '$full', '$full.complete'";
+ }
+ else {
+ unlink($full) || die "Could not unlink file: $file";
+ }
+
+ my $cache = $self->_update_state($self->[STATE]->[0], $obj);
+ $self->_process_event($obj, $cache);
+ $self->_finalize_event($obj, $cache);
+ }
+
+ closedir($dh);
+}
+
+sub done_testing {
+ my $self = shift;
+ my ($ctx, $num) = @_;
+ my $state = $self->[STATE]->[-1];
+
+ if (my $old = $state->[STATE_ENDED]) {
+ my ($p1, $f1, $l1) = $old->call;
+ $ctx->ok(0, "done_testing() was already called at $f1 line $l1");
+ return;
+ }
+
+ if ($self->[FOLLOW_UPS]) {
+ $_->($ctx) for @{$self->[FOLLOW_UPS]};
+ }
+
+ $state->[STATE_ENDED] = $ctx->snapshot;
+
+ my $ran = $state->[STATE_COUNT];
+ my $plan = $state->[STATE_PLAN] ? $state->[STATE_PLAN]->max : 0;
+
+ if (defined($num) && $plan && $num != $plan) {
+ $ctx->ok(0, "planned to run $plan but done_testing() expects $num");
+ return;
+ }
+
+ $ctx->plan($num || $plan || $ran) unless $state->[STATE_PLAN];
+
+ if ($plan && $plan != $ran) {
+ $state->[STATE_PASSING] = 0;
+ return;
+ }
+
+ if ($num && $num != $ran) {
+ $state->[STATE_PASSING] = 0;
+ return;
+ }
+
+ unless ($ran) {
+ $state->[STATE_PASSING] = 0;
+ return;
+ }
+}
+
+sub send {
+ my ($self, $e) = @_;
+
+ # Subtest state management
+ if ($e->isa('Test::Stream::Event::Child')) {
+ if ($e->action eq 'push') {
+ $e->context->note("Subtest: " . $e->name) if $self->[SUBTEST_TAP_INSTANT] && !$e->no_note;
+
+ push @{$self->[STATE]} => [0, 0, undef, 1];
+ push @{$self->[SUBTESTS]} => [];
+ push @{$self->[SUBTEST_TODO]} => $e->context->in_todo;
+ push @{$self->[SUBTEST_EXCEPTION]} => undef;
+
+ return $e;
+ }
+ else {
+ pop @{$self->[SUBTEST_TODO]};
+ my $events = pop @{$self->[SUBTESTS]} || confess "Unbalanced subtest stack (events)!";
+ my $state = pop @{$self->[STATE]} || confess "Unbalanced subtest stack (state)!";
+ confess "Child pop left the stream without a state!" unless @{$self->[STATE]};
+
+ $e = Test::Stream::Event::Subtest->new_from_pairs(
+ context => $e->context,
+ created => $e->created,
+ events => $events,
+ state => $state,
+ name => $e->name,
+ exception => pop @{$self->[SUBTEST_EXCEPTION]},
+ );
+ }
+ }
+
+ my $cache = $self->_update_state($self->[STATE]->[-1], $e);
+
+ # Subtests get dibbs on events
+ if (@{$self->[SUBTESTS]}) {
+ $e->context->set_diag_todo(1) if $self->[SUBTEST_TODO]->[-1];
+ $e->set_in_subtest(scalar @{$self->[SUBTESTS]});
+ push @{$self->[SUBTESTS]->[-1]} => $e;
+
+ $self->_render_tap($cache) if $self->[SUBTEST_TAP_INSTANT] && !$cache->{no_out};
+ }
+ elsif($self->[_USE_FORK] && ($$ != $self->[PID] || get_tid() != $self->[TID])) {
+ $self->fork_out($e);
+ }
+ else {
+ $self->_process_event($e, $cache);
+ }
+
+ $self->_finalize_event($e, $cache);
+
+ return $e;
+}
+
+sub _update_state {
+ my ($self, $state, $e) = @_;
+ my $cache = {tap_event => $e, state => $state};
+
+ if ($e->isa('Test::Stream::Event::Ok')) {
+ $cache->{do_tap} = 1;
+ $state->[STATE_COUNT]++;
+ if (!$e->bool) {
+ $state->[STATE_FAILED]++;
+ $state->[STATE_PASSING] = 0;
+ }
+ }
+ elsif (!$self->[NO_HEADER] && $e->isa('Test::Stream::Event::Finish')) {
+ if ($self->[FOLLOW_UPS]) {
+ $_->($e->context) for @{$self->[FOLLOW_UPS]};
+ }
+
+ $state->[STATE_ENDED] = $e->context->snapshot;
+
+ my $plan = $state->[STATE_PLAN];
+ if ($plan && $e->tests_run && $plan->directive eq 'NO PLAN') {
+ $plan->set_max($state->[STATE_COUNT]);
+ $plan->set_directive(undef);
+ $cache->{tap_event} = $plan;
+ $cache->{do_tap} = 1;
+ }
+ else {
+ $cache->{do_tap} = 0;
+ $cache->{no_out} = 1;
+ }
+ }
+ elsif ($self->[NO_DIAG] && $e->isa('Test::Stream::Event::Diag')) {
+ $cache->{no_out} = 1;
+ }
+ elsif ($e->isa('Test::Stream::Event::Plan')) {
+ $cache->{is_plan} = 1;
+
+ if($self->[NO_HEADER]) {
+ $cache->{no_out} = 1;
+ }
+ elsif(my $existing = $state->[STATE_PLAN]) {
+ my $directive = $existing ? $existing->directive : '';
+
+ if ($existing && (!$directive || $directive eq 'NO PLAN')) {
+ my ($p1, $f1, $l1) = $existing->context->call;
+ my ($p2, $f2, $l2) = $e->context->call;
+ die "Tried to plan twice!\n $f1 line $l1\n $f2 line $l2\n";
+ }
+ }
+
+ my $directive = $e->directive;
+ $cache->{no_out} = 1 if $directive && $directive eq 'NO PLAN';
+ }
+
+ push @{$state->[STATE_LEGACY]} => $e if $self->[USE_LEGACY];
+
+ $cache->{number} = $state->[STATE_COUNT];
+
+ return $cache;
+}
+
+sub _process_event {
+ my ($self, $e, $cache) = @_;
+
+ if ($self->[MUNGERS]) {
+ $_->($self, $e) for @{$self->[MUNGERS]};
+ }
+
+ $self->_render_tap($cache) unless $cache->{no_out};
+
+ if ($self->[LISTENERS]) {
+ $_->($self, $e) for @{$self->[LISTENERS]};
+ }
+}
+
+sub _render_tap {
+ my ($self, $cache) = @_;
+
+ return if $^C;
+ return unless $self->[USE_TAP];
+ my $e = $cache->{tap_event};
+ return unless $cache->{do_tap} || $e->can('to_tap');
+
+ my $num = $self->use_numbers ? $cache->{number} : undef;
+ confess "XXX" unless $e->can('to_tap');
+ my @sets = $e->to_tap($num, $self->[SUBTEST_TAP_DELAYED]);
+
+ my $in_subtest = $e->in_subtest || 0;
+ my $indent = ' ' x $in_subtest;
+
+ for my $set (@sets) {
+ my ($hid, $msg) = @$set;
+ next unless $msg;
+ my $enc = $e->encoding || confess "Could not find encoding!";
+ my $io = $self->[IO_SETS]->{$enc}->[$hid] || confess "Could not find IO $hid for $enc";
+
+ local($\, $", $,) = (undef, ' ', '');
+ $msg =~ s/^/$indent/mg if $in_subtest;
+ print $io $msg;
+ }
+}
+
+sub _finalize_event {
+ my ($self, $e, $cache) = @_;
+
+ if ($cache->{is_plan}) {
+ $cache->{state}->[STATE_PLAN] = $e;
+ return unless $e->directive;
+ return unless $e->directive eq 'SKIP';
+
+ $self->[SUBTEST_EXCEPTION]->[-1] = $e if $e->in_subtest;
+
+ die $e if $e->in_subtest || !$self->[EXIT_ON_DISRUPTION];
+ exit 0;
+ }
+ elsif (!$cache->{do_tap} && $e->isa('Test::Stream::Event::Bail')) {
+ $self->[BAILED_OUT] = $e;
+ $self->[NO_ENDING] = 1;
+
+ $self->[SUBTEST_EXCEPTION]->[-1] = $e if $e->in_subtest;
+
+ die $e if $e->in_subtest || !$self->[EXIT_ON_DISRUPTION];
+ exit 255;
+ }
+}
+
+sub _reset {
+ my $self = shift;
+
+ return unless $self->pid != $$ || $self->tid != get_tid();
+
+ $self->[PID] = $$;
+ $self->[TID] = get_tid();
+ if (USE_THREADS || $self->[_USE_FORK]) {
+ $self->[_USE_FORK] = undef;
+ $self->use_fork;
+ }
+ $self->[STATE] = [[0, 0, undef, 1]];
+}
+
+sub CLONE {
+ for my $stream (_stack()) {
+ next unless defined $stream->pid;
+ next unless defined $stream->tid;
+
+ next if $$ == $stream->pid && get_tid() == $stream->tid;
+
+ $stream->[IN_SUBTHREAD] = 1;
+ }
+}
+
+sub DESTROY {
+ my $self = shift;
+
+ return if $self->in_subthread;
+
+ my $dir = $self->[_USE_FORK] || return;
+
+ return unless defined $self->pid;
+ return unless defined $self->tid;
+
+ return unless $$ == $self->pid;
+ return unless get_tid() == $self->tid;
+
+ if ($ENV{TEST_KEEP_TMP_DIR}) {
+ print STDERR "# Not removing temp dir: $dir\n";
+ return;
+ }
+
+ opendir(my $dh, $dir) || confess "Could not open temp dir! ($dir)";
+ while(my $file = readdir($dh)) {
+ next if $file =~ m/^\.+$/;
+ die "Unculled event! You ran tests in a child process, but never pulled them in!\n"
+ if $file !~ m/\.complete$/;
+ unlink("$dir/$file") || confess "Could not unlink file: '$dir/$file'";
+ }
+ closedir($dh);
+ rmdir($dir) || warn "Could not remove temp dir ($dir)";
+}
+
+sub STORABLE_freeze {
+ my ($self, $cloning) = @_;
+ return if $cloning;
+ return ($self);
+}
+
+sub STORABLE_thaw {
+ my ($self, $cloning, @vals) = @_;
+ return if $cloning;
+ return Test::Stream->shared;
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream - A modern infrastructure for testing.
+
+=head1 SYNOPSYS
+
+ # Enables modern enhancements such as forking support and TAP encoding.
+ # Also turns off expensive legacy support.
+ use Test::Stream;
+ use Test::More;
+
+ # ... Tests ...
+
+ done_testing;
+
+=head1 FEATURES
+
+When you load Test::Stream inside your test file you prevent Test::More from
+turning on some expensive legacy support. You will also get warnings if your
+code, or any other code you load uses deprecated or discouraged practices.
+
+=head1 IMPORT ARGUMENTS
+
+Any import argument not recognised will be treated as an export, if it is not a
+valid export an exception will be thrown.
+
+=over 4
+
+=item '-internal'
+
+This argument, I<when given first>, will prevent the import process from
+turning on enhanced features. This is mainly for internal use (thus the name)
+in order to access/load Test::Stream.
+
+=item subtest_tap => 'none'
+
+Do not show events within subtests, just the subtest result itself.
+
+=item subtest_tap => 'instant'
+
+Show events as they happen (this is how legacy Test::More worked). This is the
+default.
+
+=item subtest_tap => 'delayed'
+
+Show events within subtest AFTER the subtest event itself is complete.
+
+=item subtest_tap => 'both'
+
+Show events as they happen, then also display them after.
+
+=item 'enable_fork'
+
+Turns on support for code that forks. This is not activated by default because
+it adds ~30ms to the Test::More compile-time, which can really add up in large
+test suites. Turn it on only when needed.
+
+=item 'utf8'
+
+Set the TAP encoding to utf8
+
+=item encoding => '...'
+
+Set the TAP encoding.
+
+=back
+
+=head1 EXPORTS
+
+=head2 DEFAULT EXPORTS
+
+=over 4
+
+=item tap_encoding( $ENCODING )
+
+Set the tap encoding from this point on.
+
+=item cull
+
+Bring in results from child processes/threads. This is automatically done
+whenever a context is obtained, but you may wish to do it on demand.
+
+=back
+
+=head2 CONSTANTS
+
+none of these are exported by default you must request them
+
+=over
+
+=item OUT_STD
+
+=item OUT_ERR
+
+=item OUT_TODO
+
+These are indexes of specific IO handles inside an IO set (each encoding has an
+IO set).
+
+=item STATE_COUNT
+
+=item STATE_FAILED
+
+=item STATE_PLAN
+
+=item STATE_PASSING
+
+=item STATE_LEGACY
+
+=item STATE_ENDED
+
+These are indexes into the STATE array present in the stream.
+
+=back
+
+=head1 THE STREAM STACK AND METHODS
+
+At any point there can be any number of streams. Most streams will be present
+in the stream stack. The stack is managed via a collection of class methods.
+You can always access the "current" or "central" stream using
+Test::Stream->shared. If you want your events to go where they are supposed to
+then you should always send them to the shared stream.
+
+It is important to note that any toogle, control, listener, munger, etc.
+applied to a stream will effect only that stream. Independant streams, streams
+down the stack, and streams added later will not get any settings from other
+stacks. Keep this in mind if you take it upon yourself to modify the stream
+stack.
+
+=head2 TOGGLES AND CONTROLS
+
+=over 4
+
+=item $stream->use_fork
+
+Turn on forking support (it cannot be turned off).
+
+=item $stream->set_subtest_tap_instant($bool)
+
+=item $bool = $stream->subtest_tap_instant
+
+Render subtest events as they happen.
+
+=item $stream->set_subtest_tap_delayed($bool)
+
+=item $bool = $stream->subtest_tap_delayed
+
+Render subtest events when printing the result of the subtest
+
+=item $stream->set_exit_on_disruption($bool)
+
+=item $bool = $stream->exit_on_disruption
+
+When true, skip_all and bailout will call exit. When false the bailout and
+skip_all events will be thrown as exceptions.
+
+=item $stream->set_use_tap($bool)
+
+=item $bool = $stream->use_tap
+
+Turn TAP rendering on or off.
+
+=item $stream->set_use_legacy($bool)
+
+=item $bool = $stream->use_legacy
+
+Turn legacy result storing on and off.
+
+=item $stream->set_use_numbers($bool)
+
+=item $bool = $stream->use_numbers
+
+Turn test numbers on and off.
+
+=back
+
+=head2 SENDING EVENTS
+
+ Test::Stream->shared->send($event)
+
+The C<send()> method is used to issue an event to the stream. This method will
+handle thread/fork sych, mungers, listeners, TAP output, etc.
+
+=head2 ALTERING EVENTS
+
+ Test::Stream->shared->munge(sub {
+ my ($stream, $event) = @_;
+
+ ... Modify the event object ...
+
+ # return is ignored.
+ });
+
+Mungers can never be removed once added. The return from a munger is ignored.
+Any changes you wish to make to the object must be done directly by altering
+it in place. The munger is called before the event is rendered as TAP, and
+AFTER the event has made any necessary state changes.
+
+=head2 LISTENING FOR EVENTS
+
+ Test::Stream->shared->listen(sub {
+ my ($stream, $event) = @_;
+
+ ... do whatever you want with the event ...
+
+ # return is ignored
+ });
+
+Listeners can never be removed once added. The return from a listener is
+ignored. Changing an event in a listener is not something you should ever do,
+though no protections are in place to prevent it (this may change!). The
+listeners are called AFTER the event has been rendered as TAP.
+
+=head2 POST-TEST BEHAVIORS
+
+ Test::Stream->shared->follow_up(sub {
+ my ($context) = @_;
+
+ ... do whatever you need to ...
+
+ # Return is ignored
+ });
+
+follow_up subs are called only once, when the stream recieves a finish event. There are 2 ways a finish event can occur:
+
+=over 4
+
+=item done_testing
+
+A finish event is generated when you call done_testing. The finish event occurs
+before the plan is output.
+
+=item EXIT MAGIC
+
+A finish event is generated when the Test::Stream END block is called, just
+before cleanup. This event will not happen if it was already geenerated by a
+call to done_testing.
+
+=back
+
+=head2 OTHER METHODS
+
+=over
+
+=item $stream->state
+
+Get the current state of the stream. The state is an array where specific
+indexes have specific meanings. These indexes are managed via constants.
+
+=item $stream->plan
+
+Get the plan event, if a plan has been issued.
+
+=item $stream->count
+
+Get the test count so far.
+
+=item $stream->failed
+
+Get the number of failed tests so far.
+
+=item $stream->ended
+
+Get the context in which the tests ended, if they have ended.
+
+=item $stream->legacy
+
+Used internally to store events for legacy support.
+
+=item $stream->is_passing
+
+Check if the test is passing its plan.
+
+=item $stream->done_testing($context, $max)
+
+Tell the stream we are done testing.
+
+=item $stream->fork_cull
+
+Gather events from other threads/processes.
+
+=back
+
+=head2 STACK METHODS AND INTERCEPTING EVENTS
+
+=over 4
+
+=item $stream = Test::Stream->shared
+
+Get the current shared stream. The shared stream is the stream at the top of
+the stack.
+
+=item Test::Stream->clear
+
+Completely remove the stream stack. It is very unlikely you will ever want to
+do this.
+
+=item ($new, $old) = Test::Stream->intercept_start($new)
+
+=item ($new, $old) = Test::Stream->intercept_start
+
+Push a new stream to the top of the stack. If you do not provide a stack a new
+one will be created for you. If you have one created for you it will have the
+following differences from a default stack:
+
+ $new->set_exit_on_disruption(0);
+ $new->set_use_tap(0);
+ $new->set_use_legacy(0);
+
+=item Test::Stream->intercept_stop($top)
+
+Pop the stack, you must pass in the instance you expect to be popped, there
+will be an exception if they do not match.
+
+=item Test::Stream->intercept(sub { ... })
+
+ Test::Stream->intercept(sub {
+ my ($new, $old) = @_;
+
+ ...
+ });
+
+Temporarily push a new stream to the top of the stack. The codeblock you pass
+in will be run. Once your codelbock returns the stack will be popped and
+restored to the previous state.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+=head1 NAME
+
+Test::Stream::Architecture - Overview of how the Test-More dist works.
+
+=head1 DESCRIPTION
+
+This is the document that explains the architecture of Test::More and all the
+stuff driving it under the hood.
+
+=head1 KEY COMPONENTS
+
+This is the list of primary components and their brief description, The most
+critical ones will have more details in later sections.
+
+=over 4
+
+=item Test::More
+
+=item Test::Simple
+
+These are the primary public interfaces for anyone who wishes to write tests.
+
+=item Test::More::Tools
+
+All of the tools Test::More provides have been relocated and refactored into
+Test::More::Tools in such a way as to make them generic and reusable. This
+means you can use them without firing off events, you can then fire off your
+own events compiled from multiple tools. In many cases this is what tool
+builders actually want, but instead they settle for bumping C<$Level> and
+calling is/like/ok and producing extra events.
+
+=item Test::Builder
+
+This B<used> to be the main under the hood module for anyone who wished to
+write a L<Test::More> compatible test library. It still works, and should be
+fully functional and backwards compatible. It is however discouraged as it is
+mostly a compatability wrapper.
+
+=item Test::Stream
+
+This is the B<new> heart and soul of the Test::* architecture. However it is
+not the primary interface. This module is responsible for collecting all events
+from all threads and processes, then forwarding them to TAP and any added
+listeners.
+
+=item Test::Stream::IOSets
+
+This module is used to manage the IO handles to which all TAP is sent.
+Test::Builder cloned STDERR and STDOUT, then applied various magic to them.
+This module provides that legacy support while also adding support for utf8 and
+other encodings. By default all TAP goes to the 'legacy' outputs, which mimick
+what Test::Builder has always done. The 'legacy' outputs are also what get
+altered if someone uses the Test::Builder->output interface.
+
+=item Test::Stream::Toolset
+
+This is the primary interface a test module author should use. It ties together
+some key functions you should use. It proved 3 critical functions:
+
+ is_tester($package)
+
+ init_tester($package)
+
+ my $ctx = context();
+
+=item Test::Stream::Context
+
+This is the primary interface as far as generating events goes. Every test
+function should grab a context, and use it to generate events.
+
+Once a context object is created (the normal way) it is remembered, and
+anything that requests a context object will obtain the same instance. However
+once the instance is destroyed (end of your test function) it is forgotten, the
+next test function to run will then obtain a new context instance.
+
+=item Test::Stream::Event
+
+=item Test::Stream::Event::Ok
+
+=item Test::Stream::Event::Diag
+
+=item Test::Stream::Event::Note
+
+=item Test::Stream::Event::*
+
+All events generated by Test::More and other test tools now boil down to a
+proper object. All events must use Test::Stream::Event as a base.
+
+=item Test::Stream::ArrayBase
+
+This is the L<Moose> of Test::Stream. It is responsible for generating
+accessors and similar work. Unlike moose and others it uses an arrayref as the
+underlying object. This design decision was made to improve performance.
+Performance was a real problem in some early alphas, the gains from the
+decision are huge.
+
+=item Test::Stream::Tester
+
+This is actually what spawned the ideas for the new Test::Stream work. This is
+a module that lets you validate your testing tools.
+
+=back
+
+=head1 THE STREAM OBJECT
+
+=over 4
+
+=item L<Test::Stream>
+
+=back
+
+=head2 HISTORY
+
+L<Test::Builder> is/was a singleton. The singleton model was chosen to solve
+the problem of synchronizing everything to a central location. Ultimately all
+results need to make their way to a central place that can assign them a
+number, and shove them through the correct output.
+
+The singleton model proved to be a major headache.
+
+Intercepting events typically meant replacing the singleton permanently
+(Test::Tester) or for a limited scope. Another option people took
+(Test::Builder::Tester) was to simply replace the IO handles Test::Builder was
+tracking.
+
+Test::Builder did not provide any real mechanisms for altering events before
+processing them, or for intercepting them before they were turned into TAP. As
+a result many modules have monkeypatched Test::Builder, particularily the
+C<ok()> method.
+
+=head2 CURRENT DESIGN
+
+Test::Stream unfortunately must still act as a singleton (mostly). But this
+time the design was to put as little as possible into the singleton.
+
+=head3 RESPONSIBILITIES OF TEST::STREAM
+
+Test::Stream has 4 main jobs:
+
+=over 4
+
+=item Collect events from all threads and processes into 1 place
+
+ $stream->send($event);
+
+The send() method will ensure that the event gets to the right place, no matter
+what thread or process you are in. (Forking support must be turned on, it is
+off by default).
+
+B<Note:> This method is key to performance. This method and everything it calls
+must remain as lean and tight as possible.
+
+=item Provide a pre-output hook for altering events
+
+ $stream->munge(sub { my ($stream, $event) = @_; ... })
+
+This lets you modify events before they are turned into output. You cannot
+remove the event, nor can you add events. Mungers are additive, and proceessed
+in the order they are added.
+
+There is not currently any way to remove a munger.
+
+B<Note:> each munger is called in a loop in the C<send()> method, so keep it as
+fast and small as possible.
+
+=item Forward all events to listeners (including TAP output)
+
+ $stream->listen(sub { my ($stream, $event) = @_; .... })
+
+This lets you add a listener. All events that come to the stream object will be
+sent to all listeners.
+
+There is not currently any way to remove a listener.
+
+B<Note:> each listener is called in a loop in the C<send()> method, so keep it is
+fast and small as possible.
+
+=item Maintaining the legacy exit behavior from Test::Builder
+
+This is primarily setting $? to the number of tests that failed, up to 255, as
+well as providing other output such as missing a plan.
+
+=back
+
+=head3 SEMI-SINGLETON MODEL
+
+Test::Stream has a semi-singleton model. Instead of 1 singleton, it is a
+singleton stack. Anything that wants to send an event to the B<current> acting
+stream should send it to the stream returned by C<< Test::Stream->shared >>.
+Nothing should ever cache this result as the B<current> stream may change.
+
+This mechanism is primarily used for intercepting, and hiding, all events for a
+limited scope. L<Test::Stream::Tester> uses this to push a stream onto the stack so
+that you can generate events that do not go to the listeners or TAP. Once the
+stack is popped the previous stream is restored allowing you to generate real
+events.
+
+You can also create new Test::Stream objects at-will that are not present in
+the stack, this lets you create alternate streams for any purpose you want.
+
+=head1 THE CONTEXT OBJECT
+
+=over 4
+
+=item L<Test::Stream::Context>
+
+=back
+
+This module is responsbile for 2 things, knowing where to report errors, and
+making it easy to issue events.
+
+=head2 ERROR REPORTING
+
+To get the context you use the C<context()> function.
+
+ sub ok {
+ my $context = context();
+ ...
+ }
+
+ ok() # Errors are reported here.
+
+If there is a context already in play, that instance will be returned.
+Otherwise a new context will be returned. The context assumes that the stack
+level just above your call is where errors should be reported.
+
+You can optionally provide an integer as the only argument, in which case that
+number will be added to the C<caller()> call to find the correct frame for
+reporting. This will be completely ignored if there is already an active
+context.
+
+ sub ok {
+ my $context = context();
+ ...
+ }
+
+ sub my_ok {
+ my $context = context();
+ ok(...);
+ }
+
+ my_ok();
+
+In the example above c<my_ok()> generates a new context, then it calls C<ok()>,
+in this case both function will have the same context object, the one generated
+by my_ok. The result is that C<ok> will report errors to the correct place.
+
+=head3 IMPLEMENTATION
+
+There is a variable C<$CURRENT> in C<Test::Stream::Context>, it is a lexical,
+so you can not touch it directly. When the C<context()> function is called, it
+first checks if $CURRENT is set, if so it returns that. If there is no current
+context it generates a new one.
+
+When a new context is generated, it is assigned to C<$CURRENT>, but then the
+reference is weakened. This means that once the returned copy falls out of
+scope, or is otherwise removed, C<$CURRENT> will vanish on its own. This means
+that so long as you hold on to your context object, anything you call will find
+it.
+
+B<The caveat> here is that if you decide to hold on to your context beyond
+your scope, you could sabatoge any future test functions. If you need to hold
+on to a context you need to call C<< $context->snapshot >>, and store the
+cloned object it returns. In general you should not need to do this, event
+objects all store the context, but do so using a snapshot.
+
+B<Note> I am open to changing this to remove the weak-reference magic and
+instead require someone to call C<< $context->release >> or similar when they
+are done with a context, but that seems more likely to result in rougue
+contexts... This method would also require its own form of reference counting..
+This decision will need to be made before we go stable.
+
+=head2 GENERATING EVENTS
+
+All event objects should use L<Test::Stream::Event> which will set them up as a
+proper event object, as well as add a method to L<Test::Stream::Context> which
+is a shortcut for generating that event type. As such you can fire off an event
+directly from your context object using the lowercase name of the event class.
+
+ my $ctx = context;
+ $ctx->ok(1, "pass");
+ $ctx->ok(0, "fail, ["This test failed, here is some diag ..."]);
+ $ctx->note("I am a teapot");
+
+All events take a context, and 2 other arguments as the first 3 arguments of
+their constructor, these shortcut methods handle those first 3 arguments for
+you, making life much easier.
+
+The other arguments are:
+
+=over 4
+
+=item created
+
+Should be an arrayref with caller information for where the event was generated.
+
+=item in_subtest
+
+True if the event belongs in a subtest, false otherwise.
+
+=back
+
+=head1 EVENT OBJECTS
+
+Here are the primary/public events. There are other events, but they are used
+internally.
+
+=over 4
+
+=item L<Test::Stream::Event>
+
+This is just a base-class, you do not use it directly.
+
+=item L<Test::Stream::Event::Diag>
+
+=item L<Test::Stream::Event::Note>
+
+=item L<Test::Stream::Event::Plan>
+
+=item L<Test::Stream::Event::Bail>
+
+These are faily simple and obvious event types.
+
+=item L<Test::Stream::Event::Ok>
+
+=item L<Test::Stream::Event::Subtest>
+
+B<Note:> C<Subtest> is a subclass of C<Ok>.
+
+Ok can contain diag objects related to that specific ok. Subtest contains all
+the events that went into the final subtest result.
+
+=back
+
+All events have a context in which they were created, which includes the file
+and line number where errors should be reported. They also have details on
+where/how they were generated. All other details are event specific.
+
+The subclass event should never be generated on its own. In fact, just use the
+subtest helpers provided by Test::More, or Test::Stream::Context. Under the
+hood a Child event is started which adds a subtest to a stack in Test::Stream,
+all events then get intercepted by that subtest. When the subtest is done you
+issue another Child event to close it out. Once closed a Subtest event will be
+generated for you and sent to the stream.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::ArrayBase;
+use strict;
+use warnings;
+
+use Test::Stream::ArrayBase::Meta;
+use Test::Stream::Carp qw/confess croak/;
+use Scalar::Util qw/blessed reftype/;
+
+use Test::Stream::Exporter();
+
+sub import {
+ my $class = shift;
+ my $caller = caller;
+
+ $class->apply_to($caller, @_);
+}
+
+sub apply_to {
+ my $class = shift;
+ my ($caller, %args) = @_;
+
+ # Make the calling class an exporter.
+ my $exp_meta = Test::Stream::Exporter::Meta->new($caller);
+ Test::Stream::Exporter->export_to($caller, 'import')
+ unless $args{no_import};
+
+ my $ab_meta = Test::Stream::ArrayBase::Meta->new($caller);
+
+ my $ISA = do { no strict 'refs'; \@{"$caller\::ISA"} };
+
+ if ($args{base}) {
+ my ($base) = grep { $_->isa($class) } @$ISA;
+
+ croak "$caller is already a subclass of '$base', cannot subclass $args{base}"
+ if $base;
+
+ my $file = $args{base};
+ $file =~ s{::}{/}g;
+ $file .= ".pm";
+ require $file unless $INC{$file};
+
+ my $pmeta = Test::Stream::ArrayBase::Meta->get($args{base});
+ croak "Base class '$args{base}' is not a subclass of $class!"
+ unless $pmeta;
+
+ push @$ISA => $args{base};
+
+ $ab_meta->subclass($args{base});
+ }
+ elsif( !grep { $_->isa($class) } @$ISA) {
+ push @$ISA => $class;
+ $ab_meta->baseclass();
+ }
+
+ $ab_meta->add_accessors(@{$args{accessors}})
+ if $args{accessors};
+}
+
+sub new {
+ my $class = shift;
+ my $self = bless [@_], $class;
+ $self->init if $self->can('init');
+ return $self;
+}
+
+sub new_from_pairs {
+ my $class = shift;
+ my %params = @_;
+ my $self = bless [], $class;
+
+ while (my ($k, $v) = each %params) {
+ my $const = uc($k);
+ croak "$class has no accessor named '$k'" unless $class->can($const);
+ my $id = $class->$const;
+ $self->[$id] = $v;
+ }
+
+ $self->init if $self->can('init');
+ return $self;
+}
+
+sub to_hash {
+ my $array_obj = shift;
+ my $meta = Test::Stream::ArrayBase::Meta->get(blessed $array_obj);
+ my $fields = $meta->fields;
+ my %out;
+ for my $f (keys %$fields) {
+ my $i = $fields->{$f};
+ my $val = $array_obj->[$i];
+ my $ao = blessed($val) && $val->isa(__PACKAGE__);
+ $out{$f} = $ao ? $val->to_hash : $val;
+ }
+ return \%out;
+};
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::ArrayBase - Base class for classes that use an arrayref instead
+of a hash.
+
+=head1 SYNOPSYS
+
+A class:
+
+ package My::Class;
+ use strict;
+ use warnings;
+
+ use Test::Stream::ArrayBase accessors => [qw/foo bar baz/];
+
+ # Chance to initialize defaults
+ sub init {
+ my $self = shift; # No other args
+ $self->[FOO] ||= "foo";
+ $self->[BAR] ||= "bar";
+ $self->[BAZ] ||= "baz";
+ }
+
+ sub print {
+ print join ", " => map { $self->[$_] } FOO, BAR, BAZ;
+ }
+
+Subclass it
+
+ package My::Subclass;
+ use strict;
+ use warnings;
+ use Test::Stream::ArrayBase base => 'My::Class', # subclass
+ accessors => ['bat'];
+
+ sub init {
+ my $self = shift;
+
+ # We get the constants from the base class for free.
+ $self->[FOO] ||= 'SubFoo';
+ $self->[BAT] || = 'bat';
+
+ $self->SUPER::init();
+ }
+
+use it:
+
+ package main;
+ use strict;
+ use warnings;
+ use My::Class;
+
+ my $one = My::Class->new('MyFoo', 'MyBar');
+
+ # Accessors!
+ my $foo = $one->foo; # 'MyFoo'
+ my $bar = $one->bar; # 'MyBar'
+ my $baz = $one->baz; # Defaulted to: 'baz'
+
+ # Setters!
+ $one->set_foo('A Foo');
+ $one->set_bar('A Bar');
+ $one->set_baz('A Baz');
+
+ # It is an arrayref, you can do this!
+ my ($foo, $bar, $baz) = @$one;
+
+ # import constants:
+ use My::Class qw/FOO BAR BAZ/;
+
+ $one->[FOO] = 'xxx';
+
+=head1 DESCRIPTION
+
+This package is used to generate classes based on arrays instead of hashes. The
+primary motivation for this is performance (not premature!). Using this class
+will give you a C<new()> method, as well as generating accessors you request.
+Generated accessors will be getters, C<set_ACCESSOR> setters will also be
+generated for you. You also get constants for each accessor (all caps) which
+return the index into the array for that accessor. Single inheritence is also
+supported. For obvious reasons you cannot use multiple inheritence with an
+array based object.
+
+=head1 METHODS
+
+=head2 PROVIDED BY ARRAY BASE
+
+=over 4
+
+=item $it = $class->new(@VALUES)
+
+Create a new instance from a list of ordered values.
+
+=item $it = $class->new_from_pairs(%ACCESSOR_VAL_PAIRS)
+
+Create a new instance using key/value pairs.
+
+=item $hr = $it->to_hash()
+
+Get a hashref dump of the object. This will also dump any ArrayBase objects
+within to a hash, but only surface-depth ones.
+
+=item $it->import()
+
+This import method is actually provided by L<Test::Stream::Exporter> and allows
+you to import the constants generated for you.
+
+=back
+
+=head2 HOOKS
+
+=over 4
+
+=item $self->init()
+
+This gives you the chance to set some default values to your fields. The only
+argument is C<$self> with its indexes already set from the constructor.
+
+=back
+
+=head1 ACCESSORS
+
+To generate accessors you list them when using the module:
+
+ use Test::Stream::ArrayBase accessors => [qw/foo/];
+
+This will generate the following subs in your namespace:
+
+=over 4
+
+=item import()
+
+This will let you import the constants
+
+=item foo()
+
+Getter, used to get the value of the C<foo> field.
+
+=item set_foo()
+
+Setter, used to set the value of the C<foo> field.
+
+=item FOO()
+
+Constant, returs the field C<foo>'s index into the class arrayref. This
+function is also exported, but only when requested. Subclasses will also get
+this function as a constant, not simply a method, that means it is copied into
+the subclass namespace.
+
+=back
+
+=head1 SUBCLASSING
+
+You can subclass an existing ArrayBase class.
+
+ use Test::Stream::ArrayBase
+ base => 'Another::ArrayBase::Class',
+ accessors => [qw/foo bar baz/],
+
+Once an ArrayBase class is used as a subclass it is locked and no new fields
+can be added. All fields in any subclass will start at the next index after the
+last field of the parent. All constants from base classes are added to
+subclasses automatically.
+
+=head1 WHY?
+
+Switching to an arrayref base has resulted in significant performance boosts.
+
+When Test::Builder was initially refactored to support events, it was slow
+beyond reason. A large part of the slowdown was due to the use of proper
+methods instead of directly accessing elements. We also switched to using a LOT
+more objects that have methods.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::ArrayBase::Meta;
+use strict;
+use warnings;
+
+use Test::Stream::Carp qw/confess/;
+
+my %META;
+
+sub package { shift->{package} }
+sub parent { shift->{parent} }
+sub locked { shift->{locked} }
+sub fields {({ %{shift->{fields}} })}
+
+sub new {
+ my $class = shift;
+ my ($pkg) = @_;
+
+ $META{$pkg} ||= bless {
+ package => $pkg,
+ locked => 0,
+ }, $class;
+
+ return $META{$pkg};
+}
+
+sub get {
+ my $class = shift;
+ my ($pkg) = @_;
+
+ return $META{$pkg};
+}
+
+sub baseclass {
+ my $self = shift;
+ $self->{parent} = 'Test::Stream::ArrayBase';
+ $self->{index} = 0;
+ $self->{fields} = {};
+}
+
+sub subclass {
+ my $self = shift;
+ my ($parent) = @_;
+ confess "Already a subclass of $self->{parent}! Tried to sublcass $parent" if $self->{parent};
+
+ my $pmeta = $self->get($parent) || die "$parent is not an ArrayBase object!";
+ $pmeta->{locked} = 1;
+
+ $self->{parent} = $parent;
+ $self->{index} = $pmeta->{index};
+ $self->{fields} = $pmeta->fields; #Makes a copy
+
+ my $ex_meta = Test::Stream::Exporter::Meta->get($self->{package});
+
+ # Put parent constants into the subclass
+ for my $field (keys %{$self->{fields}}) {
+ my $const = uc $field;
+ no strict 'refs';
+ *{"$self->{package}\::$const"} = $parent->can($const) || confess "Could not find constant '$const'!";
+ $ex_meta->add($const);
+ }
+}
+
+my $IDX = -1;
+my (@CONST, @GET, @SET);
+_GROW(20);
+
+sub _GROW {
+ my ($max) = @_;
+ return if $max <= $IDX;
+ for (($IDX + 1) .. $max) {
+ # Var per sub for inlining/constant stuff.
+ my $c = $_;
+ my $gi = $_;
+ my $si = $_;
+
+ $CONST[$_] = sub() { $c };
+ $GET[$_] = sub { $_[0]->[$gi] };
+ $SET[$_] = sub { $_[0]->[$si] = $_[1] };
+ }
+ $IDX = $max;
+}
+
+*add_accessor = \&add_accessors;
+sub add_accessors {
+ my $self = shift;
+
+ confess "Cannot add accessor, metadata is locked due to a subclass being initialized ($self->{parent}).\n"
+ if $self->{locked};
+
+ my $ex_meta = Test::Stream::Exporter::Meta->get($self->{package});
+
+ for my $name (@_) {
+ confess "field '$name' already defined!"
+ if exists $self->{fields}->{$name};
+
+ my $idx = $self->{index}++;
+ $self->{fields}->{$name} = $idx;
+
+ _GROW($IDX + 10) if $idx > $IDX;
+
+ my $const = uc $name;
+ my $gname = lc $name;
+ my $sname = "set_$gname";
+
+ {
+ no strict 'refs';
+ *{"$self->{package}\::$const"} = $CONST[$idx];
+ *{"$self->{package}\::$gname"} = $GET[$idx];
+ *{"$self->{package}\::$sname"} = $SET[$idx];
+ }
+
+ $ex_meta->{exports}->{$const} = $CONST[$idx];
+ push @{$ex_meta->{polist}} => $const;
+ }
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::ArrayBase::Meta - Meta Object for ArrayBase objects.
+
+=head1 SYNOPSYS
+
+B<Note:> You probably do not want to directly use this object.
+
+ my $meta = Test::Stream::ArrayBase::Meta->new('Some::Class');
+ $meta->add_accessor('foo');
+
+=head1 DESCRIPTION
+
+This is the meta-object used by L<Test::Stream::ArrayBase>
+
+=head1 METHODS
+
+=over 4
+
+=item $meta = $class->new($package)
+
+Create a new meta object for the specified class. If one already exists that
+instance is returned.
+
+=item $meta = $class->get($package)
+
+Get the meta object for the specified class. Returns C<undef> if there is none
+initiated.
+
+=item $package = $meta->package
+
+Get the package the meta-object manages.
+
+=item $package = $meta->parent
+
+Get the parent package to the one being managed.
+
+=item $bool = $meta->locked
+
+True if the package has been locked. Locked means no new accessors can be
+added. A package is locked once something else subclasses it.
+
+=item $hr = $meta->fields
+
+Get a hashref defining the fields on the package. This is primarily for
+internal use, it is not very useful outside.
+
+=item $meta->baseclass
+
+Make the package inherit from ArrayBase directly.
+
+=item $meta->subclass($package)
+
+Set C<$package> as the base class of the managed package.
+
+=item $meta->add_accessor($name)
+
+Add an accessor to the package. Also defines the C<"set_$name"> method, and the
+C<uc($name)> constant.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Carp;
+use strict;
+use warnings;
+
+use Test::Stream::Exporter;
+
+export croak => sub { require Carp; goto &Carp::croak };
+export confess => sub { require Carp; goto &Carp::confess };
+export cluck => sub { require Carp; goto &Carp::cluck };
+export carp => sub { require Carp; goto &Carp::carp };
+
+Test::Stream::Exporter->cleanup;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Carp - Delayed Carp loader.
+
+=head1 DESCRIPTION
+
+Use this package instead of L<Carp> to avoid loading L<Carp> until absolutely
+necessary. This is used instead of Carp in L<Test::Stream> in order to avoid
+loading modules that packages you test may need to load themselves.
+
+=head1 SUPPORTED EXPORTS
+
+See L<Carp> for details on each of these functions.
+
+=over 4
+
+=item croak
+
+=item confess
+
+=item cluck
+
+=item carp
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Context;
+use strict;
+use warnings;
+
+use Scalar::Util qw/blessed weaken/;
+
+use Test::Stream::Carp qw/confess/;
+
+use Test::Stream::Threads;
+use Test::Stream::Event();
+use Test::Stream::Util qw/try translate_filename/;
+use Test::Stream::Meta qw/init_tester is_tester/;
+
+use Test::Stream::ArrayBase(
+ accessors => [qw/frame stream encoding in_todo todo modern pid skip diag_todo provider monkeypatch_stash/],
+);
+
+use Test::Stream::Exporter qw/import export_to default_exports/;
+default_exports qw/context/;
+Test::Stream::Exporter->cleanup();
+
+{
+ no warnings 'once';
+ $Test::Builder::Level ||= 1;
+}
+
+my $CURRENT;
+
+sub init {
+ $_[0]->[FRAME] ||= _find_context(1); # +1 for call to init
+ $_[0]->[STREAM] ||= Test::Stream->shared;
+ $_[0]->[ENCODING] ||= 'legacy';
+ $_[0]->[PID] ||= $$;
+}
+
+sub peek { $CURRENT }
+sub clear { $CURRENT = undef }
+
+sub set {
+ $CURRENT = pop;
+ weaken($CURRENT);
+}
+
+my $WARNED;
+sub context {
+ my ($level, $stream) = @_;
+ # If the context has already been initialized we simply return it, we
+ # ignore any additional parameters as they no longer matter. The first
+ # thing to ask for a context wins, anything context aware that is called
+ # later MUST expect that it can get a context found by something down the
+ # stack.
+ if ($CURRENT) {
+ return $CURRENT unless $stream;
+ return $CURRENT if $stream == $CURRENT->[STREAM];
+ }
+
+ my $call = _find_context($level);
+ $call = _find_context_harder() unless $call;
+ my $pkg = $call->[0];
+
+ my $meta = is_tester($pkg) || _find_tester();
+
+ # Check if $TODO is set in the package, if not check if Test::Builder is
+ # loaded, and if so if it has Todo set. We check the element directly for
+ # performance.
+ my ($todo, $in_todo);
+ {
+ my $todo_pkg = $meta->[Test::Stream::Meta::PACKAGE];
+ no strict 'refs';
+ no warnings 'once';
+ if ($todo = $meta->[Test::Stream::Meta::TODO]) {
+ $in_todo = 1;
+ }
+ elsif ($todo = ${"$pkg\::TODO"}) {
+ $in_todo = 1;
+ }
+ elsif ($todo = ${"$todo_pkg\::TODO"}) {
+ $in_todo = 1;
+ }
+ elsif ($Test::Builder::Test && defined $Test::Builder::Test->{Todo}) {
+ $todo = $Test::Builder::Test->{Todo};
+ $in_todo = 1;
+ }
+ else {
+ $in_todo = 0;
+ }
+ };
+
+ my ($ppkg, $pname);
+ if(my @provider = caller(1)) {
+ ($ppkg, $pname) = ($provider[3] =~ m/^(.*)::([^:]+)$/);
+ }
+
+ # Uh-Oh! someone has replaced the singleton, that means they probably want
+ # everything to go through them... We can't do a whole lot about that, but
+ # we will use the singletons stream which should catch most use-cases.
+ if ($Test::Builder::_ORIG_Test && $Test::Builder::_ORIG_Test != $Test::Builder::Test) {
+ $stream ||= $Test::Builder::Test->{stream};
+
+ my $warn = $meta->[Test::Stream::Meta::MODERN]
+ && !$WARNED++;
+
+ warn <<" EOT" if $warn;
+
+ *******************************************************************************
+ Something replaced the singleton \$Test::Builder::Test.
+
+ The Test::Builder singleton is no longer the central place for all test
+ events. Please look at Test::Stream, and Test::Stream->intercept() to
+ accomplish the type of thing that was once done with the singleton.
+
+ All attempts have been made to preserve compatability with older modules,
+ but if you experience broken behavior you may need to update your code. If
+ updating your code is not an option you will need to downgrade to a
+ Test::More prior to version 1.301001. Patches that restore compatability
+ without breaking necessary Test::Stream functionality will be gladly
+ accepted.
+ *******************************************************************************
+ EOT
+ }
+
+ $stream ||= $meta->[Test::Stream::Meta::STREAM] || Test::Stream->shared || confess "No Stream!?";
+ if ((USE_THREADS || $stream->_use_fork) && ($stream->pid == $$ && $stream->tid == get_tid())) {
+ $stream->fork_cull();
+ }
+
+ my $encoding = $meta->[Test::Stream::Meta::ENCODING] || 'legacy';
+ $call->[1] = translate_filename($encoding => $call->[1]) if $encoding ne 'legacy';
+
+ my $ctx = bless(
+ [
+ $call,
+ $stream,
+ $encoding,
+ $in_todo,
+ $todo,
+ $meta->[Test::Stream::Meta::MODERN] || 0,
+ $$,
+ undef,
+ $in_todo,
+ [$ppkg, $pname]
+ ],
+ __PACKAGE__
+ );
+
+ weaken($ctx->[STREAM]);
+
+ return $ctx if $CURRENT;
+
+ $CURRENT = $ctx;
+ weaken($CURRENT);
+ return $ctx;
+}
+
+sub _find_context {
+ my ($add) = @_;
+
+ $add ||= 0;
+ my $tb = $Test::Builder::Level - 1;
+
+ # 0 - call to find_context
+ # 1 - call to context/new
+ # 2 - call to tool
+ my $level = 2 + $add + $tb;
+ my ($package, $file, $line, $subname) = caller($level);
+
+ return unless $package;
+
+ while ($package eq 'Test::Builder') {
+ ($package, $file, $line, $subname) = caller(++$level);
+ }
+
+ return unless $package;
+
+ return [$package, $file, $line, $subname];
+}
+
+sub _find_context_harder {
+ my $level = 0;
+ my $fallback;
+ while(1) {
+ my ($pkg, $file, $line, $subname) = caller($level++);
+ $fallback ||= [$pkg, $file, $line, $subname] if $subname =~ m/::END$/;
+ next if $pkg =~ m/^Test::(Stream|Builder|More|Simple)(::.*)?$/;
+ return [$pkg, $file, $line, $subname];
+ }
+
+ return $fallback if $fallback;
+ return [ '<UNKNOWN>', '<UNKNOWN>', 0, '<UNKNOWN>' ];
+}
+
+sub _find_tester {
+ my $level = 2;
+ while(1) {
+ my $pkg = caller($level++);
+ last unless $pkg;
+ my $meta = is_tester($pkg) || next;
+ return $meta;
+ }
+
+ # find a .t file!
+ $level = 0;
+ while(1) {
+ my ($pkg, $file) = caller($level++);
+ last unless $pkg;
+ if ($file eq $0 && $file =~ m/\.t$/) {
+ return init_tester($pkg);
+ }
+ }
+
+ return init_tester('main');
+}
+
+sub alert {
+ my $self = shift;
+ my ($msg) = @_;
+
+ my @call = $self->call;
+
+ warn "$msg at $call[1] line $call[2].\n";
+}
+
+sub throw {
+ my $self = shift;
+ my ($msg) = @_;
+
+ my @call = $self->call;
+
+ $CURRENT = undef if $CURRENT = $self;
+
+ die "$msg at $call[1] line $call[2].\n";
+}
+
+sub call { @{$_[0]->[FRAME]} }
+
+sub package { $_[0]->[FRAME]->[0] }
+sub file { $_[0]->[FRAME]->[1] }
+sub line { $_[0]->[FRAME]->[2] }
+sub subname { $_[0]->[FRAME]->[3] }
+
+sub snapshot {
+ return bless [@{$_[0]}], blessed($_[0]);
+}
+
+sub send {
+ my $self = shift;
+ $self->[STREAM]->send(@_);
+}
+
+# Uhg.. support legacy monkeypatching
+# If this is still here in 2020 I will be a sad panda.
+{
+ sub ok {
+ return _ok(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{ok} != \&Test::Builder::ok;
+ my $self = shift;
+ local $Test::Builder::CTX = $self;
+ my ($bool, $name, @stash) = @_;
+ push @{$self->[MONKEYPATCH_STASH]} => \@stash;
+ my $out = Test::Builder->new->ok($bool, $name);
+ return $out;
+ }
+
+ sub _unwind_ok {
+ my $self = shift;
+ my ($bool, $name) = @_;
+ my $stash = pop @{$self->[MONKEYPATCH_STASH]};
+ return $self->_ok($bool, $name, @$stash);
+ }
+
+ sub note {
+ return _note(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{note} != \&Test::Builder::note;
+ local $Test::Builder::CTX = shift;
+ my $out = Test::Builder->new->note(@_);
+ return $out;
+ }
+
+ sub diag {
+ return _diag(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{diag} != \&Test::Builder::diag;
+ local $Test::Builder::CTX = shift;
+ my $out = Test::Builder->new->diag(@_);
+ return $out;
+ }
+
+ sub plan {
+ return _plan(@_) unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{plan} != \&Test::Builder::plan;
+ local $Test::Builder::CTX = shift;
+ my ($num, $dir, $arg) = @_;
+ $dir ||= 'tests';
+ $dir = 'skip_all' if $dir eq 'SKIP';
+ $dir = 'no_plan' if $dir eq 'NO PLAN';
+ my $out = Test::Builder->new->plan($dir, $num || $arg || ());
+ return $out;
+ }
+
+ sub done_testing {
+ return $_[0]->stream->done_testing(@_)
+ unless $INC{'Test/Builder.pm'} && $Test::Builder::ORIG{done_testing} != \&Test::Builder::done_testing;
+
+ local $Test::Builder::CTX = shift;
+ my $out = Test::Builder->new->done_testing(@_);
+ return $out;
+ }
+}
+
+my %EVENTS;
+sub events { \%EVENTS }
+
+sub register_event {
+ my $class = shift;
+ my ($pkg, $name) = @_;
+
+ my $real_name = lc($pkg);
+ $real_name =~ s/^.*:://g;
+
+ $name ||= $real_name;
+
+ confess "Method '$name' is already defined, event '$pkg' cannot get a context method!"
+ if $class->can($name);
+
+ $EVENTS{$real_name} = $pkg;
+
+ # Use a string eval so that we get a names sub instead of __ANON__
+ local ($@, $!);
+ eval qq|
+ sub $name {
+ my \$self = shift;
+ my \@call = caller(0);
+ my \$encoding = \$self->[ENCODING];
+ \$call[1] = translate_filename(\$encoding => \$call[1]) if \$encoding ne 'legacy';
+ my \$e = '$pkg'->new(\$self->snapshot, [\@call[0 .. 4]], 0, \@_);
+ return \$self->stream->send(\$e);
+ };
+ 1;
+ | || die $@;
+}
+
+sub meta { is_tester($_[0]->[FRAME]->[0]) }
+
+sub hide_todo {
+ my $self = shift;
+ no strict 'refs';
+ no warnings 'once';
+
+ my $pkg = $self->[FRAME]->[0];
+ my $meta = is_tester($pkg);
+
+ my $found = {
+ TB => $Test::Builder::Test ? $Test::Builder::Test->{Todo} : undef,
+ META => $meta->[Test::Stream::Meta::TODO],
+ PKG => ${"$pkg\::TODO"},
+ };
+
+ $Test::Builder::Test->{Todo} = undef;
+ $meta->[Test::Stream::Meta::TODO] = undef;
+ ${"$pkg\::TODO"} = undef;
+
+ return $found;
+}
+
+sub restore_todo {
+ my $self = shift;
+ my ($found) = @_;
+ no strict 'refs';
+ no warnings 'once';
+
+ my $pkg = $self->[FRAME]->[0];
+ my $meta = is_tester($pkg);
+
+ $Test::Builder::Test->{Todo} = $found->{TB};
+ $meta->[Test::Stream::Meta::TODO] = $found->{META};
+ ${"$pkg\::TODO"} = $found->{PKG};
+
+ my $found2 = {
+ TB => $Test::Builder::Test ? $Test::Builder::Test->{Todo} : undef,
+ META => $meta->[Test::Stream::Meta::TODO] || undef,
+ PKG => ${"$pkg\::TODO"} || undef,
+ };
+
+ for my $k (qw/TB META PKG/) {
+ no warnings 'uninitialized';
+ next if "$found->{$k}" eq "$found2->{$k}";
+ die "Mismatch! $k:\t$found->{$k}\n\t$found2->{$k}\n"
+ }
+
+ return;
+}
+
+sub DESTROY { 1 }
+
+our $AUTOLOAD;
+sub AUTOLOAD {
+ my $class = blessed($_[0]) || $_[0] || confess $AUTOLOAD;
+
+ my $name = $AUTOLOAD;
+ $name =~ s/^.*:://g;
+
+ my $module = 'Test/Stream/Event/' . ucfirst(lc($name)) . '.pm';
+ try { require $module };
+
+ my $sub = $class->can($name);
+ goto &$sub if $sub;
+
+ my ($pkg, $file, $line) = caller;
+
+ die qq{Can't locate object method "$name" via package "$class" at $file line $line.\n};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Context - Object to represent a testing context.
+
+=head1 DESCRIPTION
+
+In testing it is important to have context. It is not helpful to simply say a
+test failed, you want to know where it failed. This object is responsible for
+tracking the context of each test that is run. It makes it possible to get the
+file and line number where the failure occured .This object is also responsible
+for generating almost all the events you will encounter.
+
+=head1 SYNOPSYS
+
+ use Test::Stream::Context qw/context/;
+
+ sub my_tool {
+ my $ctx = context();
+
+ # Generate an event.
+ $ctx->ok(1, "Pass!");
+ }
+
+ 1;
+
+=head1 EXPORTS
+
+=over 4
+
+=item $ctx = context()
+
+This function is used to obtain a context. If there is already a context object
+in scope this will return it, otherwise it will return a new one.
+
+It is important that you never store a context object in a variable from a
+higher scope, a package variable, or an object attribute. The scope of a
+context matters a lot.
+
+If you want to store a context for later reference use the C<snapshot()> method
+to get a clone of it that is safe to store anywhere.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $ctx->alert($MESSAGE)
+
+This issues a warning at the calling context (filename and line number where
+errors should be reported).
+
+=item $ctx->throw($MESSAGE)
+
+This throws an exception at the calling context (filename and line number where
+errors should be reported).
+
+=item ($package, $file, $line, $subname) = $ctx->call()
+
+Get the caller details for the context. This is where errors should be
+reported.
+
+=item $pkg = $ctx->package
+
+Get the context package.
+
+=item $file = $ctx->file
+
+Get the context filename.
+
+=item $line = $ctx->line
+
+Get the context line number.
+
+=item $subname = $ctx->subname
+
+Get the context subroutine name.
+
+=item $ctx_copy = $ctx->snapshot
+
+Get a copy of the context object that is safe to store for later reference.
+
+=item $ctx->send($event)
+
+Send an event to the correct L<Test::Stream> object.
+
+=item $ctx = $class->peek
+
+Get the current context object, if there is one.
+
+=back
+
+=head2 DANGEROUS ONES
+
+=over 4
+
+=item $ctx->set
+
+=item $cclass->set($ctx)
+
+Set the context object as the current one, replacing any that might already be
+current.
+
+=item $class->clear
+
+Unset the current context.
+
+=item $ctx->register_event($package)
+
+=item $ctx->register_event($package, $name)
+
+Register a new event type, creating the shortcut method to generate it. If
+C<$name> is not provided it will be taken from the end of the package name, and
+will be lowercased.
+
+=item $hr = $ctx->events
+
+Get the hashref that holds C<< (name => $package) >> pairs. This is the actual
+ref used by the package, so please do not alter it.
+
+=item $stash = $ctx->hide_todo
+
+=item $ctx->restore_todo($stash)
+
+These are used to temporarily hide the TODO value in ALL places where it might
+be found. The returned C<$stash> must be used to restore it later.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Event;
+use strict;
+use warnings;
+
+use Scalar::Util qw/blessed/;
+use Test::Stream::Carp qw/confess/;
+
+use Test::Stream::ArrayBase(
+ accessors => [qw/context created in_subtest/],
+ no_import => 1,
+);
+
+sub import {
+ my $class = shift;
+
+ # Import should only when event is imported, subclasses do not use this
+ # import.
+ return if $class ne __PACKAGE__;
+
+ my $caller = caller;
+ my (%args) = @_;
+
+ my $ctx_meth = delete $args{ctx_method};
+
+ require Test::Stream::Context;
+ require Test::Stream;
+
+ # %args may override base
+ Test::Stream::ArrayBase->apply_to($caller, base => $class, %args);
+ Test::Stream::Context->register_event($caller, $ctx_meth);
+ Test::Stream::Exporter::export_to(
+ 'Test::Stream',
+ $caller,
+ qw/OUT_STD OUT_ERR OUT_TODO/,
+ );
+}
+
+sub init {
+ confess("No context provided!") unless $_[0]->[CONTEXT];
+}
+
+sub encoding { $_[0]->[CONTEXT]->encoding }
+
+sub extra_details {}
+
+sub summary {
+ my $self = shift;
+ my $type = blessed $self;
+ $type =~ s/^.*:://g;
+
+ my $ctx = $self->context;
+
+ my ($package, $file, $line) = $ctx->call;
+ my ($tool_pkg, $tool_name) = @{$ctx->provider};
+ $tool_name =~ s/^\Q$tool_pkg\E:://;
+
+ return (
+ type => lc($type),
+
+ $self->extra_details(),
+
+ package => $package || undef,
+ file => $file,
+ line => $line,
+
+ tool_package => $tool_pkg,
+ tool_name => $tool_name,
+
+ encoding => $ctx->encoding || undef,
+ in_todo => $ctx->in_todo || 0,
+ todo => $ctx->todo || '',
+ pid => $ctx->pid || 0,
+ skip => $ctx->skip || '',
+ );
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Event - Base class for events
+
+=head1 DESCRIPTION
+
+Base class for all event objects that get passed through
+L<Test::Stream>.
+
+=head1 SYNOPSYS
+
+ package Test::Stream::Event::MyEvent;
+ use strict;
+ use warnings;
+
+ # This will make our class an event subclass, add the specified accessors,
+ # inject a helper method into the context objects, and add constants for
+ # all our fields, and fields we inherit.
+ use Test::Stream::Event(
+ accessors => [qw/foo bar baz/],
+ ctx_method => 'my_event',
+ );
+
+ # Chance to initialize some defaults
+ sub init {
+ my $self = shift;
+ # no other args in @_
+
+ $self->SUPER::init();
+
+ $self->set_foo('xxx') unless defined $self->foo;
+
+ # Events are arrayrefs, all accessors have a constant defined with
+ # their index.
+ $self->[BAR] ||= "";
+
+ ...
+ }
+
+ # If your event produces TAP output it must define this method
+ sub to_tap {
+ my $self = shift;
+ return (
+ # Constants are defined at import, all are optional, and may appear
+ # any number of times.
+ [OUT_STD, $self->foo],
+ [OUT_ERR, $self->bar],
+ [OUT_STD, $self->baz],
+ );
+ }
+
+ # This is your hook to add details to the summary fields.
+ sub extra_details {
+ my $self = shift;
+
+ my @super_details = $self->SUPER::extra_details();
+
+ return (
+ @super_details,
+
+ foo => $self->foo || undef,
+ bar => $self->bar || '',
+ ...
+ );
+ }
+
+ 1;
+
+=head1 IMPORTING
+
+=head2 ARGUMENTS
+
+In addition to the arguments listed here, you may pass in any arguments
+accepted by L<Test::Stream::ArrayBase>.
+
+=over 4
+
+=item ctx_method => $NAME
+
+This specifies the name of the helper meth that will be injected into
+L<Test::Stream::Context> to help generate your events. If this is not specified
+it will use the lowercased last section of your package name.
+
+=item base => $BASE_CLASS
+
+This lets you specify an event class to subclass. B<THIS MUST BE AN EVENT
+CLASS>. If you do not specify anything here then C<Test::Stream::Event> will be
+used.
+
+=item accessors => \@FIELDS
+
+This lets you define any fields you wish to be present in your class. This is
+the only way to define storage for your event. Each field specified will get a
+read-only accessor with the same name as the field, as well as a setter
+C<set_FIELD()>. You will also get a constant that returns the index of the
+field in the classes arrayref. The constant is the name of the field in all
+upper-case.
+
+=back
+
+=head2 SUBCLASSING
+
+C<Test::Stream::Event> is added to your @INC for you, unless you specify an
+alternative base class, which must itself subclass C<Test::Stream::Event>.
+
+Events B<CAN NOT> use multiple inheritance in most cases. This is mainly
+because events are arrayrefs and not hashrefs. Each subclass must add fields as
+new indexes after the last index of the parent class.
+
+=head2 CONTEXT HELPER
+
+All events need some initial fields for construction. These fields include a
+context, and some other state from construction time. The context object will
+get helper methods for all events that fill in these fields for you. It is not
+advised to ever construct an event object yourself, you should I<always> use
+the context helper method.
+
+=head1 EVENTS ARE ARRAY REFERENCES
+
+Events are an arrayref. Events use L<Test::Stream::ArrayBase> under the hood to
+generate accessors, constants, and field indexes. The key thing to take away
+from this is that you cannot add attributes on the fly, you B<MUST> use
+L<Test::Stream::Event> and/or L<Test::Stream::ArrayBase> to add fields.
+
+If you need a place to store extar generic, and possibly unpredictable, data,
+you should add a field and assign a hashref to it, then use that hashref to
+store your mixed data.
+
+=head1 METHODS
+
+=over 4
+
+=item $ctx = $e->context
+
+Get a snapshot of the context as it was when this event was generated
+
+=item $call = $e->created
+
+Get the C<caller()> details from when the objects was created. This is usually
+the call to the tool that generated the event such as C<Test::More::ok()>.
+
+=item $bool = $e->in_subtest
+
+Check if the event was generated within a subtest.
+
+=item $encoding = $e->encoding
+
+Get the encoding that was in effect when the event was generated
+
+=item @details = $e->extra_details
+
+Get an ordered key/value pair list of summary fields for the event. Override
+this to add additional fields.
+
+=item @summary = $e->summary
+
+Get an ordered key/value pair list of summary fields for the event, including
+parent class fields. In general you should not override this as it has a useful
+(thought not depended upon) order.
+
+=back
+
+=head1 SUMMARY FIELDS
+
+These are the fields that will be present when calling
+C<< my %sum = $e->summary >>. Please note that the fields are returned as an
+order key+pair list, they can be directly assigned to a hash if desired, or
+they can be assigned to an array to preserver the order. The order is as it
+appears below, B<NOT> alphabetical.
+
+=over 4
+
+=item type
+
+The name of the event type, typically this is the lowercase form of the last
+part of the class name.
+
+=item package
+
+The package that generated this event.
+
+=item file
+
+The file in which the event was generated, and to which errors should be attributed.
+
+=item line
+
+The line number on which the event was generated, and to which errors should be
+attributed.
+
+=item tool_package
+
+The package that provided the tool that generated the event (example:
+Test::More)
+
+=item tool_name
+
+The name of the sub that produced the event (examples: C<ok()>, C<is()>).
+
+=item encoding
+
+The encoding that should be used when printing the TAP output from this event.
+
+=item in_todo
+
+True if the event was generated while TODO was in effect.
+
+=item todo
+
+The todo message if the event was generated with TODO in effect.
+
+=item pid
+
+The PID in which the event was generated.
+
+=item skip
+
+The skip message if the event was generated via skip.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Event::Bail;
+use strict;
+use warnings;
+
+use Test::Stream::Event(
+ accessors => [qw/reason quiet/],
+);
+
+sub to_tap {
+ my $self = shift;
+ return if $self->[QUIET];
+ return [
+ OUT_STD,
+ "Bail out! " . $self->reason . "\n",
+ ];
+}
+
+sub extra_details {
+ my $self = shift;
+ return (
+ $self->reason || '',
+ $self->quiet || 0,
+ );
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Event::Bail - Bailout!
+
+=head1 DESCRIPTION
+
+The bailout event is generated when things go horribly wrong and you need to
+halt all testing in the current file.
+
+=head1 SYNOPSYS
+
+ use Test::Stream::Context qw/context/;
+ use Test::Stream::Event::Bail;
+
+ my $ctx = context();
+ my $event = $ctx->bail('Stuff is broken');
+
+=head1 METHODS
+
+Inherits from L<Test::Stream::Event>. Also defines:
+
+=over 4
+
+=item $reason = $e->reason
+
+The reason for the bailout.
+
+=item $bool = quiet
+
+Should the bailout be quiet?
+
+=back
+
+=head1 SUMMARY FIELDS
+
+These are the fields that will be present when calling
+C<< my %sum = $e->summary >>. Please note that the fields are returned as an
+order key+pair list, they can be directly assigned to a hash if desired, or
+they can be assigned to an array to preserver the order. The order is as it
+appears below, B<NOT> alphabetical.
+
+=over 4
+
+=item reason
+
+Reason for the bailout
+
+=item quiet
+
+Boolean, true if the bailout should be quiet.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Event::Child;
+use strict;
+use warnings;
+
+use Test::Stream::Carp qw/confess/;
+use Test::Stream::Event(
+ accessors => [qw/action name no_note/],
+);
+
+sub init {
+ confess "did not get an action" unless $_[0]->[ACTION];
+ confess "action must be either 'push' or 'pop', not '$_[0]->[ACTION]'"
+ unless $_[0]->[ACTION] =~ m/^(push|pop)$/;
+
+ $_[0]->[NAME] ||= "";
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Event::Child - Child event type
+
+=head1 DESCRIPTION
+
+B<YOU PROBABLY DO NOT WANT TO USE THIS YOURSELF>
+
+Child events are used under the hood to start and stop subtests.
+L<Test::Stream::Event::Subtest> events are generated by child events.
+
+=head1 SYNOPSYS
+
+ use Test::Stream::Context qw/context/;
+ use Test::Stream::Event::Bail;
+
+ my $ctx = context();
+ $ctx->child( 'push', $NAME );
+
+ ... # Generate events
+
+ # Generates a subtest event
+ $ctx->child( 'pop', $NAME );
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Event::Diag;
+use strict;
+use warnings;
+
+use Test::Stream::Event(
+ accessors => [qw/message linked/],
+ ctx_method => '_diag',
+);
+
+use Test::Stream::Util qw/try/;
+use Scalar::Util qw/weaken/;
+use Test::Stream::Carp qw/confess/;
+
+sub init {
+ $_[0]->[MESSAGE] = 'undef' unless defined $_[0]->[MESSAGE];
+ weaken($_[0]->[LINKED]) if $_[0]->[LINKED];
+}
+
+sub link {
+ my $self = shift;
+ my ($to) = @_;
+ confess "Already linked!" if $self->[LINKED];
+ $self->[LINKED] = $to;
+ weaken($self->[LINKED]);
+}
+
+sub to_tap {
+ my $self = shift;
+
+ chomp(my $msg = $self->[MESSAGE]);
+
+ $msg = "# $msg" unless $msg =~ m/^\n/;
+ $msg =~ s/\n/\n# /g;
+
+ return [
+ ($self->[CONTEXT]->diag_todo ? OUT_TODO : OUT_ERR),
+ "$msg\n",
+ ];
+}
+
+sub extra_details {
+ my $self = shift;
+ return ( message => $self->message || '' );
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Event::Diag - Diag event type
+
+=encoding utf8
+
+=head1 DESCRIPTION
+
+Diagnostics messages, typically rendered to STDERR.
+
+=head1 SYNOPSYS
+
+ use Test::Stream::Context qw/context/;
+ use Test::Stream::Event::Diag;
+
+ my $ctx = context();
+ my $event = $ctx->diag($message);
+
+=head1 ACCESSORS
+
+=over 4
+
+=item $diag->message
+
+The message for the diag.
+
+=item $diag->linked
+
+The Ok event the diag is linked to, if it is.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $diag->link($ok);
+
+Link the diag to an OK event.
+
+=back
+
+=head1 SUMMARY FIELDS
+
+=over 4
+
+=item message
+
+The message from the diag.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Event::Finish;
+use strict;
+use warnings;
+
+use Test::Stream::Event(
+ accessors => [qw/tests_run tests_failed/],
+);
+
+sub extra_details {
+ my $self = shift;
+ return (
+ tests_run => $self->tests_run || 0,
+ tests_failed => $self->tests_failed || 0,
+ );
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Event::Finish - The finish event type
+
+=head1 DESCRIPTION
+
+Sent after testing is finished.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Event::Note;
+use strict;
+use warnings;
+
+use Test::Stream::Event(
+ accessors => [qw/message/],
+ ctx_method => '_note',
+);
+
+use Test::Stream::Carp qw/confess/;
+
+sub init {
+ $_[0]->[MESSAGE] = 'undef' unless defined $_[0]->[MESSAGE];
+}
+
+sub to_tap {
+ my $self = shift;
+
+ chomp(my $msg = $self->[MESSAGE]);
+ $msg = "# $msg" unless $msg =~ m/^\n/;
+ $msg =~ s/\n/\n# /g;
+
+ return [OUT_STD, "$msg\n"];
+}
+
+sub extra_details {
+ my $self = shift;
+ return ( message => $self->message || '' );
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Event::Note - Note event type
+
+=encoding utf8
+
+=head1 DESCRIPTION
+
+Notes, typically rendered to STDOUT.
+
+=head1 SYNOPSYS
+
+ use Test::Stream::Context qw/context/;
+ use Test::Stream::Event::Note;
+
+ my $ctx = context();
+ my $event = $ctx->Note($message);
+
+=head1 ACCESSORS
+
+=over 4
+
+=item $note->message
+
+The message for the note.
+
+=back
+
+=head1 SUMMARY FIELDS
+
+=over 4
+
+=item message
+
+The message from the note.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Event::Ok;
+use strict;
+use warnings;
+
+use Scalar::Util qw/blessed/;
+use Test::Stream::Util qw/unoverload_str/;
+use Test::Stream::Carp qw/confess/;
+
+use Test::Stream::Event(
+ accessors => [qw/real_bool name diag bool level/],
+ ctx_method => '_ok',
+);
+
+sub skip { $_[0]->[CONTEXT]->skip }
+sub todo { $_[0]->[CONTEXT]->todo }
+
+sub init {
+ my $self = shift;
+
+ # Do not store objects here, only true/false/undef
+ if ($self->[REAL_BOOL]) {
+ $self->[REAL_BOOL] = 1;
+ }
+ elsif(defined $self->[REAL_BOOL]) {
+ $self->[REAL_BOOL] = 0;
+ }
+ $self->[LEVEL] = $Test::Builder::Level;
+
+ my $ctx = $self->[CONTEXT];
+ my $rb = $self->[REAL_BOOL];
+ my $todo = $ctx->in_todo;
+ my $skip = defined $ctx->skip;
+ my $b = $rb || $todo || $skip || 0;
+ my $diag = delete $self->[DIAG];
+ my $name = $self->[NAME];
+
+ $self->[BOOL] = $b ? 1 : 0;
+
+ unless ($rb || ($todo && $skip)) {
+ my $msg = $todo ? "Failed (TODO)" : "Failed";
+ my $prefix = $ENV{HARNESS_ACTIVE} ? "\n" : "";
+
+ my ($pkg, $file, $line) = $ctx->call;
+
+ if (defined $name) {
+ $msg = qq[$prefix $msg test '$name'\n at $file line $line.];
+ }
+ else {
+ $msg = qq[$prefix $msg test at $file line $line.];
+ }
+
+ $self->add_diag($msg);
+ }
+
+ $self->add_diag(" You named your test '$name'. You shouldn't use numbers for your test names.\n Very confusing.")
+ if $name && $name =~ m/^[\d\s]+$/;
+
+ $self->add_diag(@$diag) if $diag && @$diag;
+}
+
+sub to_tap {
+ my $self = shift;
+ my ($num) = @_;
+
+ my $name = $self->[NAME];
+ my $context = $self->[CONTEXT];
+ my $skip = $context->skip;
+ my $todo = $context->todo;
+
+ my @out;
+ push @out => "not" unless $self->[REAL_BOOL];
+ push @out => "ok";
+ push @out => $num if defined $num;
+
+ unoverload_str \$name if defined $name;
+
+ if ($name) {
+ $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
+ push @out => ("-", $name);
+ }
+
+ if (defined $skip && defined $todo) {
+ push @out => "# TODO & SKIP";
+ push @out => $todo if length $todo;
+ }
+ elsif ($context->in_todo) {
+ push @out => "# TODO";
+ push @out => $todo if length $todo;
+ }
+ elsif (defined $skip) {
+ push @out => "# skip";
+ push @out => $skip if length $skip;
+ }
+
+ my $out = join " " => @out;
+ $out =~ s/\n/\n# /g;
+
+ return [OUT_STD, "$out\n"] unless $self->[DIAG];
+
+ return (
+ [OUT_STD, "$out\n"],
+ map {$_->to_tap($num)} @{$self->[DIAG]},
+ );
+}
+
+sub add_diag {
+ my $self = shift;
+
+ my $context = $self->[CONTEXT];
+ my $created = $self->[CREATED];
+
+ for my $item (@_) {
+ next unless $item;
+
+ if (ref $item) {
+ confess("Only diag objects can be linked to events.")
+ unless blessed($item) && $item->isa('Test::Stream::Event::Diag');
+
+ $item->link($self);
+ }
+ else {
+ $item = Test::Stream::Event::Diag->new($context, $created, $self->[IN_SUBTEST], $item, $self);
+ }
+
+ push @{$self->[DIAG]} => $item;
+ }
+}
+
+{
+ # Yes, we do want to override the imported one.
+ no warnings 'redefine';
+ sub clear_diag {
+ my $self = shift;
+ return unless $self->[DIAG];
+ my $out = $self->[DIAG];
+ $self->[DIAG] = undef;
+ $_->set_linked(undef) for @$out;
+ return $out;
+ }
+}
+
+sub to_legacy {
+ my $self = shift;
+
+ my $result = {};
+ $result->{ok} = $self->bool ? 1 : 0;
+ $result->{actual_ok} = $self->real_bool;
+ $result->{name} = $self->name;
+
+ my $ctx = $self->context;
+
+ if($self->skip && ($ctx->in_todo || $ctx->todo)) {
+ $result->{type} = 'todo_skip',
+ $result->{reason} = $ctx->skip || $ctx->todo;
+ }
+ elsif($ctx->in_todo || $ctx->todo) {
+ $result->{reason} = $ctx->todo;
+ $result->{type} = 'todo';
+ }
+ elsif($ctx->skip) {
+ $result->{reason} = $ctx->skip;
+ $result->{type} = 'skip';
+ }
+ else {
+ $result->{reason} = '';
+ $result->{type} = '';
+ }
+
+ if ($result->{reason} eq 'incrementing test number') {
+ $result->{type} = 'unknown';
+ }
+
+ return $result;
+}
+
+sub extra_details {
+ my $self = shift;
+
+ require Test::Stream::Tester::Events;
+
+ my $diag = join "\n", map {
+ my $msg = $_->message;
+ chomp($msg);
+ split /[\n\r]+/, $msg;
+ } @{$self->diag || []};
+
+ return (
+ diag => $diag || '',
+ bool => $self->bool || 0,
+ name => $self->name || undef,
+ real_bool => $self->real_bool || 0
+ );
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Event::Ok - Ok event type
+
+=encoding utf8
+
+=head1 DESCRIPTION
+
+Ok events are generated whenever you run a test that produces a result.
+Examples are C<ok()>, and C<is()>.
+
+=head1 SYNOPSYS
+
+ use Test::Stream::Context qw/context/;
+ use Test::Stream::Event::Ok;
+
+ my $ctx = context();
+ my $event = $ctx->ok($bool, $name, \@diag);
+
+=head1 ACCESSORS
+
+=over 4
+
+=item $rb = $e->real_bool
+
+This is the true/false value of the test after TODO, SKIP, and similar
+modifiers are taken into account.
+
+=item $name = $e->name
+
+Name of the test.
+
+=item $diag = $e->diag
+
+An arrayref with all the L<Test::Stream::Event::Diag> events reduced down to
+just the messages. Some coaxing has beeen done to combine all the messages into
+a single string.
+
+=item $b = $e->bool
+
+The original true/false value of whatever was passed into the event (but
+reduced down to 1 or 0).
+
+=item $l = $e->level
+
+For legacy L<Test::Builder> support. Do not use this, it can go away, or change
+behavior at any time.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $le = $e->to_legacy
+
+Returns a hashref that matches some legacy details about ok's. You should
+probably not use this for anything new.
+
+=item $e->add_diag($diag_event, "diag message" ...)
+
+Add a diag to the event. The diag may be a diag event, or a simple string.
+
+=item $diag = $e->clear_diag
+
+Remove all diag events, then return them in an arrayref.
+
+=back
+
+=head1 SUMMARY FIELDS
+
+=over 4
+
+=item diag
+
+A single string with all the messages from the diags linked to the event.
+
+=item bool
+
+True/False passed into the test.
+
+=item name
+
+Name of the test.
+
+=item real_bool
+
+True/False value accounting for TODO and SKIP.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Event::Plan;
+use strict;
+use warnings;
+
+use Test::Stream::Event(
+ accessors => [qw/max directive reason/],
+ ctx_method => '_plan',
+);
+
+use Test::Stream::Carp qw/confess/;
+
+my %ALLOWED = (
+ 'SKIP' => 1,
+ 'NO PLAN' => 1,
+);
+
+sub init {
+ if ($_[0]->[DIRECTIVE]) {
+ $_[0]->[DIRECTIVE] = 'SKIP' if $_[0]->[DIRECTIVE] eq 'skip_all';
+ $_[0]->[DIRECTIVE] = 'NO PLAN' if $_[0]->[DIRECTIVE] eq 'no_plan';
+
+ confess "'" . $_[0]->[DIRECTIVE] . "' is not a valid plan directive"
+ unless $ALLOWED{$_[0]->[DIRECTIVE]};
+ }
+ else {
+ $_[0]->[DIRECTIVE] = '';
+ confess "Cannot have a reason without a directive!"
+ if defined $_[0]->[REASON];
+
+ confess "No number of tests specified"
+ unless defined $_[0]->[MAX];
+
+
+ }
+}
+
+sub to_tap {
+ my $self = shift;
+
+ my $max = $self->[MAX];
+ my $directive = $self->[DIRECTIVE];
+ my $reason = $self->[REASON];
+
+ return if $directive && $directive eq 'NO PLAN';
+
+ my $plan = "1..$max";
+ if ($directive) {
+ $plan .= " # $directive";
+ $plan .= " $reason" if defined $reason;
+ }
+
+ return [OUT_STD, "$plan\n"];
+}
+
+sub extra_details {
+ my $self = shift;
+ return (
+ max => $self->max || 0,
+ directive => $self->directive || undef,
+ reason => $self->reason || undef
+ );
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Event::Plan - The event of a plan
+
+=encoding utf8
+
+=head1 DESCRIPTION
+
+Plan events are fired off whenever a plan is declared, done testing is called,
+or a subtext completes.
+
+=head1 SYNOPSYS
+
+ use Test::Stream::Context qw/context/;
+ use Test::Stream::Event::Plan;
+
+ my $ctx = context();
+ my $event = $ctx->plan($max, $directive, $reason);
+
+=head1 ACCESSORS
+
+=over 4
+
+=item $num = $plan->max
+
+Get the number of expected tests
+
+=item $dir = $plan->directive
+
+Get the directive (such as TODO, skip_all, or no_plan).
+
+=item $reason = $plan->reason
+
+Get the reason for the directive.
+
+=back
+
+=head1 SUMMARY FIELDS
+
+=over 4
+
+=item max
+
+Number of expected tests.
+
+=item directive
+
+Directive.
+
+=item reason
+
+Reason for directive.
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Event::Subtest;
+use strict;
+use warnings;
+
+use Scalar::Util qw/blessed/;
+use Test::Stream::Carp qw/confess/;
+use Test::Stream qw/-internal STATE_PASSING STATE_COUNT STATE_FAILED STATE_PLAN/;
+
+use Test::Stream::Event(
+ base => 'Test::Stream::Event::Ok',
+ accessors => [qw/state events exception/],
+);
+
+sub init {
+ my $self = shift;
+
+ $self->[REAL_BOOL] = $self->[STATE]->[STATE_PASSING] && $self->[STATE]->[STATE_COUNT];
+ $self->[EVENTS] ||= [];
+
+ if (my $le = $self->[EXCEPTION]) {
+ my $is_skip = $le->isa('Test::Stream::Event::Plan');
+ $is_skip &&= $le->directive;
+ $is_skip &&= $le->directive eq 'SKIP';
+
+ if ($is_skip) {
+ my $skip = $le->reason || "skip all";
+ # Should be a snapshot now:
+ $self->[CONTEXT]->set_skip($skip);
+ $self->[REAL_BOOL] = 1;
+ }
+ }
+
+ push @{$self->[DIAG]} => ' No tests run for subtest.'
+ unless $self->[EXCEPTION] || $self->[STATE]->[STATE_COUNT];
+
+ $self->SUPER::init();
+}
+
+sub to_tap {
+ my $self = shift;
+ my ($num, $delayed) = @_;
+
+ unless($delayed) {
+ return if $self->[EXCEPTION]
+ && $self->[EXCEPTION]->isa('Test::Stream::Event::Bail');
+
+ return $self->SUPER::to_tap($num);
+ }
+
+ # Subtest final result first
+ $self->[NAME] =~ s/$/ {/mg;
+ my @out = (
+ $self->SUPER::to_tap($num),
+ $self->_render_events(@_),
+ [OUT_STD, "}\n"],
+ );
+ $self->[NAME] =~ s/ \{$//mg;
+ return @out;
+}
+
+sub _render_events {
+ my $self = shift;
+ my ($num, $delayed) = @_;
+
+ my $idx = 0;
+ my @out;
+ for my $e (@{$self->events}) {
+ next unless $e->can('to_tap');
+ $idx++ if $e->isa('Test::Stream::Event::Ok');
+ push @out => $e->to_tap($idx, $delayed);
+ }
+
+ for my $set (@out) {
+ $set->[1] =~ s/^/ /mg;
+ }
+
+ return @out;
+}
+
+sub extra_details {
+ my $self = shift;
+
+ my @out = $self->SUPER::extra_details();
+ my $plan = $self->[STATE]->[STATE_PLAN];
+ my $exception = $self->exception;
+
+ return (
+ @out,
+
+ events => $self->events || undef,
+
+ exception => $exception || undef,
+ plan => $plan || undef,
+
+ passing => $self->[STATE]->[STATE_PASSING],
+ count => $self->[STATE]->[STATE_COUNT],
+ failed => $self->[STATE]->[STATE_FAILED],
+ );
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Event::Subtest - Subtest event
+
+=head1 DESCRIPTION
+
+This event is used to encapsulate subtests.
+
+=head1 SYNOPSYS
+
+B<YOU PROBABLY DO NOT WANT TO DIRECTLY GENERATE A SUBTEST EVENT>. See the
+C<subtest()> function from L<Test::More::Tools> instead.
+
+=head1 INHERITENCE
+
+the C<Test::Stream::Event::Subtest> class inherits from
+L<Test::Stream::Event::Ok> and shares all of its methods and fields.
+
+=head1 ACCESSORS
+
+=over 4
+
+=item my $se = $e->events
+
+This returns an arrayref with all events generated during the subtest.
+
+=item my $x = $e->exception
+
+If the subtest was killed by a C<skip_all> or C<BAIL_OUT> the event will be
+returned by this accessor.
+
+=back
+
+=head1 SUMMARY FIELDS
+
+C<Test::Stream::Event::Subtest> inherits all of the summary fields from
+L<Test::Stream::Event::Ok>.
+
+=over 4
+
+=item events => \@subevents
+
+An arrayref containing all the events generated within the subtest, including
+plans.
+
+=item exception => \$plan_or_bail
+
+If the subtest was aborted due to a bail-out or a skip_all, the event that
+caused the abort will be here (in addition to the events arrayref.
+
+=item plan => \$plan
+
+The plan event for the subtest, this may be auto-generated.
+
+=item passing => $bool
+
+True if the subtest was passing, false otherwise. This should not be confused
+with 'bool' inherited from L<Test::Stream::Event::Ok> which takes TODO into
+account.
+
+=item count => $num
+
+Number of tests run inside the subtest.
+
+=item failed => $num
+
+Number of tests that failed inside the subtest.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::ExitMagic;
+use strict;
+use warnings;
+
+require Test::Stream::ExitMagic::Context;
+
+use Test::Stream::ArrayBase(
+ accessors => [qw/pid done/],
+);
+
+sub init {
+ $_[0]->[PID] = $$;
+ $_[0]->[DONE] = 0;
+}
+
+sub do_magic {
+ my $self = shift;
+ my ($stream, $context) = @_;
+ return unless $stream;
+ return if $stream->no_ending && !$context;
+
+ # Don't bother with an ending if this is a forked copy. Only the parent
+ # should do the ending.
+ return unless $self->[PID] == $$;
+
+ # Only run once
+ return if $self->[DONE]++;
+
+ my $real_exit_code = $?;
+
+ my $plan = $stream->plan;
+ my $total = $stream->count;
+ my $fails = $stream->failed;
+
+ $context ||= Test::Stream::ExitMagic::Context->new([caller()], $stream);
+ $context->finish($total, $fails);
+
+ # Ran tests but never declared a plan or hit done_testing
+ return $self->no_plan_magic($stream, $context, $total, $fails, $real_exit_code)
+ if $total && !$plan;
+
+ # Exit if plan() was never called. This is so "require Test::Simple"
+ # doesn't puke.
+ return unless $plan;
+
+ # Don't do an ending if we bailed out.
+ if( $stream->bailed_out ) {
+ $stream->is_passing(0);
+ return;
+ }
+
+ # Figure out if we passed or failed and print helpful messages.
+ return $self->be_helpful_magic($stream, $context, $total, $fails, $plan, $real_exit_code)
+ if $total && $plan;
+
+ if ($plan->directive && $plan->directive eq 'SKIP') {
+ $? = 0;
+ return;
+ }
+
+ if($real_exit_code) {
+ $context->diag("Looks like your test exited with $real_exit_code before it could output anything.\n");
+ $stream->is_passing(0);
+ $? = $real_exit_code;
+ return;
+ }
+
+ unless ($total) {
+ $context->diag("No tests run!\n");
+ $stream->is_passing(0);
+ $? = 255;
+ return;
+ }
+
+ $stream->is_passing(0);
+ $? = 255;
+}
+
+sub no_plan_magic {
+ my $self = shift;
+ my ($stream, $context, $total, $fails, $real_exit_code) = @_;
+
+ $stream->is_passing(0);
+ $context->diag("Tests were run but no plan was declared and done_testing() was not seen.");
+
+ if($real_exit_code) {
+ $context->diag("Looks like your test exited with $real_exit_code just after $total.\n");
+ $? = $real_exit_code;
+ return;
+ }
+
+ # But if the tests ran, handle exit code.
+ if ($total && $fails) {
+ my $exit_code = $fails <= 254 ? $fails : 254;
+ $? = $exit_code;
+ return;
+ }
+
+ $? = 254;
+ return;
+}
+
+sub be_helpful_magic {
+ my $self = shift;
+ my ($stream, $context, $total, $fails, $plan, $real_exit_code) = @_;
+
+ my $planned = $plan->max;
+ my $num_extra = $plan->directive && $plan->directive eq 'NO PLAN' ? 0 : $total - $planned;
+
+ if ($num_extra != 0) {
+ my $s = $planned == 1 ? '' : 's';
+ $context->diag("Looks like you planned $planned test$s but ran $total.\n");
+ $stream->is_passing(0);
+ }
+
+ if($fails) {
+ my $s = $fails == 1 ? '' : 's';
+ my $qualifier = $num_extra == 0 ? '' : ' run';
+ $context->diag("Looks like you failed $fails test$s of ${total}${qualifier}.\n");
+ $stream->is_passing(0);
+ }
+
+ if($real_exit_code) {
+ $context->diag("Looks like your test exited with $real_exit_code just after $total.\n");
+ $stream->is_passing(0);
+ $? = $real_exit_code;
+ return;
+ }
+
+ my $exit_code;
+ if($fails) {
+ $exit_code = $fails <= 254 ? $fails : 254;
+ }
+ elsif($num_extra != 0) {
+ $exit_code = 255;
+ }
+ else {
+ $exit_code = 0;
+ }
+
+ $? = $exit_code;
+ return;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::ExitMagic - Encapsulate the magic exit logic
+
+=head1 DESCRIPTION
+
+It's magic! well kinda..
+
+=head1 SYNOPSYS
+
+Don't use this yourself, let L<Test::Stream> handle it.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::ExitMagic::Context;
+use strict;
+use warnings;
+
+use Test::Stream::ArrayBase(
+ base => 'Test::Stream::Context',
+);
+
+sub init {
+ $_[0]->[PID] = $$;
+ $_[0]->[ENCODING] = 'legacy';
+}
+
+sub snapshot { $_[0] }
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::ExitMagic::Context - Special context for use in an END block.
+
+=head1 DESCRIPTION
+
+L<Test::Stream> needs to accomplish some magic in an END block. In an END block
+it is not always possible to have a true/complete context object, so this
+trivial one is used instead.
+
+B<DO NOT USE THIS>. If you find yourself thinking that you should use this then
+B<STOP!> because you are very likely to be wrong.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Exporter;
+use strict;
+use warnings;
+
+use Test::Stream::PackageUtil;
+use Test::Stream::Exporter::Meta;
+
+sub export;
+sub exports;
+sub default_export;
+sub default_exports;
+
+# Test::Stream::Carp uses this module.
+sub croak { require Carp; goto &Carp::croak }
+sub confess { require Carp; goto &Carp::confess }
+
+BEGIN { Test::Stream::Exporter::Meta->new(__PACKAGE__) };
+
+sub import {
+ my $class = shift;
+ my $caller = caller;
+
+ Test::Stream::Exporter::Meta->new($caller);
+
+ export_to($class, $caller, @_);
+}
+
+default_exports qw/export exports default_export default_exports/;
+exports qw/export_to export_meta export_to_level/;
+
+default_export import => sub {
+ my $class = shift;
+ my $caller = caller;
+ my @args = @_;
+
+ my $stash = $class->before_import($caller, \@args) if $class->can('before_import');
+ export_to($class, $caller, @args);
+ $class->after_import($caller, $stash, @args) if $class->can('after_import');
+};
+
+sub export_meta {
+ my $pkg = shift || caller;
+ return Test::Stream::Exporter::Meta->get($pkg);
+}
+
+sub export_to {
+ my $class = shift;
+ my ($dest, @imports) = @_;
+
+ my $meta = Test::Stream::Exporter::Meta->new($class);
+
+ my (@include, %exclude);
+ for my $import (@imports) {
+ if (substr($import, 0, 1) eq '!') {
+ $import =~ s/^!//g;
+ $exclude{$import}++;
+ }
+ else {
+ push @include => $import;
+ }
+ }
+
+ @include = $meta->default unless @include;
+
+ my $exports = $meta->exports;
+ for my $name (@include) {
+ next if $exclude{$name};
+
+ my $ref = $exports->{$name}
+ || croak qq{"$name" is not exported by the $class module};
+
+ no strict 'refs';
+ $name =~ s/^[\$\@\%\&]//;
+ *{"$dest\::$name"} = $ref;
+ }
+}
+
+sub export_to_level {
+ my $class = shift;
+ my ($level, undef, @want) = @_;
+
+ my $dest = caller($level);
+ my $export_to = $class->can('export_to') || \&export_to;
+
+ $class->$export_to($dest, @want);
+}
+
+sub cleanup {
+ my $pkg = caller;
+ package_purge_sym($pkg, map {(CODE => $_)} qw/export exports default_export default_exports/);
+}
+
+sub export {
+ my ($name, $ref) = @_;
+ my $caller = caller;
+
+ my $meta = export_meta($caller) ||
+ confess "$caller is not an exporter!?";
+
+ $meta->add($name, $ref);
+}
+
+sub exports {
+ my $caller = caller;
+
+ my $meta = export_meta($caller) ||
+ confess "$caller is not an exporter!?";
+
+ $meta->add_bulk(@_);
+}
+
+sub default_export {
+ my ($name, $ref) = @_;
+ my $caller = caller;
+
+ my $meta = export_meta($caller) ||
+ confess "$caller is not an exporter!?";
+
+ $meta->add_default($name, $ref);
+}
+
+sub default_exports {
+ my $caller = caller;
+
+ my $meta = export_meta($caller) ||
+ confess "$caller is not an exporter!?";
+
+ $meta->add_default_bulk(@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Exporter - Declarative exporter for Test::Stream and friends.
+
+=head1 DESCRIPTION
+
+Test::Stream::Exporter is an internal implementation of some key features from
+L<Exporter::Declare>. This is a much more powerful exporting tool than
+L<Exporter>. This package is used to easily manage complicated EXPORT logic
+across L<Test::Stream> and friends.
+
+=head1 SYNOPSYS
+
+ use Test::Stream::Exporter;
+
+ # Export some named subs from the package
+ default_exports qw/foo bar baz/;
+ exports qw/fluxx buxx suxx/;
+
+ # Export some anonymous subs under specific names.
+ export some_tool => sub { ... };
+ default_export another_tool => sub { ... };
+
+ # Call this when you are done providing exports in order to cleanup your
+ # namespace.
+ Test::Stream::Exporter->cleanup;
+
+ # Hooks for import()
+
+ # Called before importing symbols listed in $args_ref. This gives you a
+ # chance to munge the arguments.
+ sub before_import {
+ my $class = shift;
+ my ($caller, $args_ref) = @_;
+ ...
+
+ return $stash; # For use in after_import, can be anything
+ }
+
+ # Chance to do something after import() is done
+ sub after_import {
+ my $class = shift;
+ my ($caller, $stash, @args) = @_;
+ ...
+ }
+
+=head1 EXPORTS
+
+=head2 DEFAULT
+
+=over 4
+
+=item import
+
+Your class needs this to function as an exporter.
+
+=item export NAME => sub { ... }
+
+=item default_export NAME => sub { ... }
+
+These are used to define exports that may not actually be subs in the current
+package.
+
+=item exports qw/foo bar baz/
+
+=item default_exports qw/foo bar baz/
+
+These let you export package subs en mass.
+
+=back
+
+=head2 AVAILABLE
+
+=over 4
+
+=item export_to($from, $dest, @symbols)
+
+=item $from->export_to($dest, @symbols)
+
+Export from the C<$from> package into the C<$dest> package. The class-method
+form only works if the method has been imported into the C<$from> package.
+
+=item $meta = export_meta($package)
+
+=item $meta = $package->export_meta()
+
+Get the export meta object from the package. The class method form only works
+if the package has imported it.
+
+=back
+
+=head1 HOOKS
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Exporter::Meta;
+use strict;
+use warnings;
+
+use Test::Stream::PackageUtil;
+
+# Test::Stream::Carp uses this module.
+sub croak { require Carp; goto &Carp::croak }
+sub confess { require Carp; goto &Carp::confess }
+
+sub exports { $_[0]->{exports} }
+sub default { @{$_[0]->{pdlist}} }
+sub all { @{$_[0]->{polist}} }
+
+sub add {
+ my $self = shift;
+ my ($name, $ref) = @_;
+
+ confess "Name is mandatory" unless $name;
+
+ confess "$name is already exported"
+ if $self->exports->{$name};
+
+ $ref ||= package_sym($self->{package}, $name);
+
+ confess "No reference or package sub found for '$name' in '$self->{package}'"
+ unless $ref && ref $ref;
+
+ $self->exports->{$name} = $ref;
+ push @{$self->{polist}} => $name;
+}
+
+sub add_default {
+ my $self = shift;
+ my ($name, $ref) = @_;
+
+ $self->add($name, $ref);
+ push @{$self->{pdlist}} => $name;
+
+ $self->{default}->{$name} = 1;
+}
+
+sub add_bulk {
+ my $self = shift;
+ for my $name (@_) {
+ confess "$name is already exported"
+ if $self->exports->{$name};
+
+ my $ref = package_sym($self->{package}, $name)
+ || confess "No reference or package sub found for '$name' in '$self->{package}'";
+
+ $self->{exports}->{$name} = $ref;
+ }
+
+ push @{$self->{polist}} => @_;
+}
+
+sub add_default_bulk {
+ my $self = shift;
+
+ for my $name (@_) {
+ confess "$name is already exported by $self->{package}"
+ if $self->exports->{$name};
+
+ my $ref = package_sym($self->{package}, $name)
+ || confess "No reference or package sub found for '$name' in '$self->{package}'";
+
+ $self->{exports}->{$name} = $ref;
+ $self->{default}->{$name} = 1;
+ }
+
+ push @{$self->{polist}} => @_;
+ push @{$self->{pdlist}} => @_;
+}
+
+my %EXPORT_META;
+
+sub new {
+ my $class = shift;
+ my ($pkg) = @_;
+
+ confess "Package is required!"
+ unless $pkg;
+
+ unless($EXPORT_META{$pkg}) {
+ # Grab anything set in @EXPORT or @EXPORT_OK
+ my (@pdlist, @polist);
+ {
+ no strict 'refs';
+ @pdlist = @{"$pkg\::EXPORT"};
+ @polist = @{"$pkg\::EXPORT_OK"};
+
+ @{"$pkg\::EXPORT"} = ();
+ @{"$pkg\::EXPORT_OK"} = ();
+ }
+
+ my $meta = bless({
+ exports => {},
+ default => {},
+ pdlist => do { no strict 'refs'; no warnings 'once'; \@{"$pkg\::EXPORT"} },
+ polist => do { no strict 'refs'; no warnings 'once'; \@{"$pkg\::EXPORT_OK"} },
+ package => $pkg,
+ }, $class);
+
+ $meta->add_default_bulk(@pdlist);
+ my %seen = map {$_ => 1} @pdlist;
+ $meta->add_bulk(grep {!$seen{$_}++} @polist);
+
+ $EXPORT_META{$pkg} = $meta;
+ }
+
+ return $EXPORT_META{$pkg};
+}
+
+sub get {
+ my $class = shift;
+ my ($pkg) = @_;
+
+ confess "Package is required!"
+ unless $pkg;
+
+ return $EXPORT_META{$pkg};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Exporter::Meta - Meta object for exporters.
+
+=head1 DESCRIPTION
+
+L<Test::Stream::Exporter> uses this package to manage exports.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::IOSets;
+use strict;
+use warnings;
+
+use Test::Stream::Util qw/protect/;
+
+init_legacy();
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+
+ $self->reset_legacy;
+
+ return $self;
+}
+
+sub init_encoding {
+ my $self = shift;
+ my ($name, @handles) = @_;
+
+ unless($self->{$name}) {
+ my ($out, $fail, $todo);
+
+ if (@handles) {
+ ($out, $fail, $todo) = @handles;
+ }
+ else {
+ ($out, $fail) = $self->open_handles();
+ }
+
+ binmode($out, ":encoding($name)");
+ binmode($fail, ":encoding($name)");
+
+ $self->{$name} = [$out, $fail, $todo || $out];
+ }
+
+ return $self->{$name};
+}
+
+my $LEGACY;
+sub hard_reset { $LEGACY = undef }
+sub init_legacy {
+ return if $LEGACY;
+
+ my ($out, $err) = open_handles();
+
+ _copy_io_layers(\*STDOUT, $out);
+ _copy_io_layers(\*STDERR, $err);
+
+ _autoflush($out);
+ _autoflush($err);
+
+ # LEGACY, BAH!
+ # This is necessary to avoid out of sequence writes to the handles
+ _autoflush(\*STDOUT);
+ _autoflush(\*STDERR);
+
+ $LEGACY = [$out, $err, $out];
+}
+
+sub reset_legacy {
+ my $self = shift;
+ init_legacy() unless $LEGACY;
+ my ($out, $fail, $todo) = @$LEGACY;
+ $self->{legacy} = [$out, $fail, $todo];
+}
+
+sub _copy_io_layers {
+ my($src, $dst) = @_;
+
+ protect {
+ require PerlIO;
+ my @src_layers = PerlIO::get_layers($src);
+ _apply_layers($dst, @src_layers) if @src_layers;
+ };
+
+ return;
+}
+
+sub _autoflush {
+ my($fh) = shift;
+ my $old_fh = select $fh;
+ $| = 1;
+ select $old_fh;
+
+ return;
+}
+
+sub open_handles {
+ open( my $out, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
+ open( my $err, ">&STDERR" ) or die "Can't dup STDERR: $!";
+
+ _autoflush($out);
+ _autoflush($err);
+
+ return ($out, $err);
+}
+
+sub _apply_layers {
+ my ($fh, @layers) = @_;
+ my %seen;
+ my @unique = grep { $_ !~ /^(unix|perlio)$/ && !$seen{$_}++ } @layers;
+ binmode($fh, join(":", "", "raw", @unique));
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::IOSets - Manage sets of IO Handles in specific encodings.
+
+=head1 DESCRIPTION
+
+The module does 2 things, first it emulates the old behavior of
+L<Test::Builder> which clones and modifies the STDOUT and STDERR handles. This
+legacy behavior can be referenced as C<'legacy'> in place of an encoding. It
+also manages multiple clones of the standard file handles which are set to
+specific encodings.
+
+=head1 METHODS
+
+In general you should not use this module yourself. If you must use it directly
+then there is really only 1 method you should use:
+
+=over 4
+
+=item $ar = $ioset->init_encoding($ENCODING)
+
+=item $ar = $ioset->init_encoding('legacy')
+
+=item $ar = $ioset->init_encoding($NAME, $STDOUT, $STDERR)
+
+C<init_encoding()> will return an arrayref of 3 filehandles, STDOUT, STDERR,
+and TODO. TODO is typically just STDOUT again. If the encoding specified has
+not yet been initialized it will initialize it. If you provide filehandles they
+will be used, but only during initializatin. Typically a filehandle set is
+created by cloning STDER and STDOUT and modifying them to use the correct
+encoding.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Meta;
+use strict;
+use warnings;
+
+use Scalar::Util();
+use Test::Stream::Util qw/protect/;
+
+use Test::Stream::ArrayBase(
+ accessors => [qw/package encoding modern todo stream/],
+);
+
+use Test::Stream::PackageUtil;
+
+use Test::Stream::Exporter qw/import export_to default_exports/;
+default_exports qw{ is_tester init_tester };
+Test::Stream::Exporter->cleanup();
+
+my %META;
+
+sub snapshot {
+ my $self = shift;
+ my $class = Scalar::Util::blessed($self);
+ return bless [@$self], $class;
+}
+
+sub is_tester {
+ my $pkg = shift;
+ return $META{$pkg};
+}
+
+sub init_tester {
+ my $pkg = shift;
+ $META{$pkg} ||= bless [$pkg, 'legacy', 0, undef], __PACKAGE__;
+ return $META{$pkg};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Meta - Meta object for unit test packages.
+
+=head1 DESCRIPTION
+
+This object is used to track metadata for unit tests packages.
+
+=head1 SYNOPSYS
+
+ use Test::Stream::Meta qw/init_tester is_tester/;
+
+ sub import {
+ my $class = shift;
+ my $caller = caller;
+
+ my $meta = init_tester($caller);
+ }
+
+ sub check_stuff {
+ my $caller = caller;
+ my $meta = is_tester($caller) || return;
+
+ ...
+ }
+
+=head1 EXPORTS
+
+=over 4
+
+=item $meta = is_tester($package)
+
+Get the meta object for a specific package, if it has one.
+
+=item $meta = init_tester($package)
+
+Get the meta object for a specific package, or create one.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $meta_copy = $meta->snapshot
+
+Get a snapshot copy of the metadata. This snapshot will not change when the
+original does.
+
+=item $val = $meta->package
+
+=item $val = $meta->encoding
+
+=item $val = $meta->modern
+
+=item $val = $meta->todo
+
+=item $val = $meta->stream
+
+These are various attributes stored on the meta object.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::PackageUtil;
+use strict;
+use warnings;
+
+sub confess { require Carp; goto &Carp::confess }
+
+my @SLOTS = qw/HASH SCALAR ARRAY IO FORMAT CODE/;
+my %SLOTS = map {($_ => 1)} @SLOTS;
+
+my %SIGMAP = (
+ '&' => 'CODE',
+ '%' => 'HASH',
+ '$' => 'SCALAR',
+ '*' => 'IO',
+);
+
+sub import {
+ my $caller = caller;
+ no strict 'refs';
+ *{"$caller\::package_sym"} = \&package_sym;
+ *{"$caller\::package_purge_sym"} = \&package_purge_sym;
+ 1;
+}
+
+sub package_sym {
+ my ($pkg, @parts) = @_;
+ confess "you must specify a package" unless $pkg;
+
+ my ($slot, $name);
+
+ if (@parts > 1) {
+ ($slot, $name) = @parts;
+ }
+ elsif (@parts) {
+ my $sig;
+ ($sig, $name) = $parts[0] =~ m/^(\W)?(\w+)$/;
+ $slot = $SIGMAP{$sig || '&'};
+ }
+
+ confess "you must specify a symbol type" unless $slot;
+ confess "you must specify a symbol name" unless $name;
+
+ confess "'$slot' is not a valid symbol type! Valid: " . join(", ", @SLOTS)
+ unless $SLOTS{$slot};
+
+ no warnings 'once';
+ no strict 'refs';
+ return *{"$pkg\::$name"}{$slot};
+}
+
+sub package_purge_sym {
+ my ($pkg, @pairs) = @_;
+
+ for(my $i = 0; $i < @pairs; $i += 2) {
+ my $purge = $pairs[$i];
+ my $name = $pairs[$i + 1];
+
+ confess "'$purge' is not a valid symbol type! Valid: " . join(", ", @SLOTS)
+ unless $SLOTS{$purge};
+
+ no strict 'refs';
+ local *GLOBCLONE = *{"$pkg\::$name"};
+ undef *{"$pkg\::$name"};
+ for my $slot (@SLOTS) {
+ next if $slot eq $purge;
+ *{"$pkg\::$name"} = *GLOBCLONE{$slot} if defined *GLOBCLONE{$slot};
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::PackageUtil - Utils for manipulating package symbol tables.
+
+=head1 DESCRIPTION
+
+Collection of utilities L<Test::Stream> and friends use to manipulate package
+symbol tables. This is primarily useful when trackign things like C<$TODO>
+vars. It is also used for exporting and meta-construction of object methods.
+
+=head1 EXPORTS
+
+Both exports are exported by default, you cannot pick and choose. These work
+equally well as functions and class-methods. These will not work as object
+methods.
+
+=over 4
+
+=item $ref = package_sym($PACKAGE, $SLOT => $NAME)
+
+Get the reference to a symbol in the package. C<$PACKAGE> should be the package
+name. C<$SLOT> should be a valid typeglob slot (Supported slots: HASH SCALAR ARRAY
+IO FORMAT CODE). C<$NAME> should be the name of the symbol.
+
+=item package_purge_sym($PACKAGE, $SLOT => $NAME, $SLOT2 => $NAME2, ...)
+
+This is used to remove symbols from a package. The first argument, C<$PACKAGE>,
+should be the name of the package. The remaining arguments should be key/value
+pairs. The key in each pair should be the typeglob slot to clear (Supported
+slots: HASH SCALAR ARRAY IO FORMAT CODE). The value in the pair should be the
+name of the symbol to remove.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Tester;
+use strict;
+use warnings;
+
+use Test::Builder 1.301001;
+use Test::Stream;
+use Test::Stream::Util qw/try/;
+
+use B;
+
+use Scalar::Util qw/blessed reftype/;
+use Test::Stream::Carp qw/croak carp/;
+
+use Test::Stream::Tester::Checks;
+use Test::Stream::Tester::Checks::Event;
+use Test::Stream::Tester::Events;
+use Test::Stream::Tester::Events::Event;
+
+use Test::Stream::Toolset;
+use Test::Stream::Exporter;
+default_exports qw{
+ intercept grab
+
+ events_are
+ check event directive
+};
+
+default_export dir => \&directive;
+Test::Stream::Exporter->cleanup;
+
+sub grab {
+ require Test::Stream::Tester::Grab;
+ return Test::Stream::Tester::Grab->new;
+}
+
+our $EVENTS;
+sub check(&) {
+ my ($code) = @_;
+
+ my $o = B::svref_2object($code);
+ my $st = $o->START;
+ my $file = $st->file;
+ my $line = $st->line;
+
+ local $EVENTS = Test::Stream::Tester::Checks->new($file, $line);
+
+ my @out = $code->($EVENTS);
+
+ if (@out) {
+ if ($EVENTS->populated) {
+ carp "sub used in check(&) returned values, did you forget to prefix an event with 'event'?"
+ }
+ else {
+ croak "No events were produced by sub in check(&), but the sub returned some values, did you forget to prefix an event with 'event'?";
+ }
+ }
+
+ return $EVENTS;
+}
+
+sub event($$) {
+ my ($type, $data) = @_;
+
+ croak "event() cannot be used outside of a check { ... } block"
+ unless $EVENTS;
+
+ my $etypes = Test::Stream::Context->events;
+ croak "'$type' is not a valid event type!"
+ unless $etypes->{$type};
+
+ my $props;
+
+ croak "event() takes a type, followed by a hashref"
+ unless ref $data && reftype $data eq 'HASH';
+
+ # Make a copy
+ $props = { %{$data} };
+
+ my @call = caller(0);
+ $props->{debug_package} = $call[0];
+ $props->{debug_file} = $call[1];
+ $props->{debug_line} = $call[2];
+
+ $EVENTS->add_event($type, $props);
+ return ();
+}
+
+sub directive($;$) {
+ my ($directive, @args) = @_;
+
+ croak "directive() cannot be used outside of a check { ... } block"
+ unless $EVENTS;
+
+ croak "No directive specified"
+ unless $directive;
+
+ if (!ref $directive) {
+ croak "Directive '$directive' requires exactly 1 argument"
+ unless (@args && @args == 1) || $directive eq 'end';
+ }
+ else {
+ croak "directives must be a predefined name, or a sub ref"
+ unless reftype($directive) eq 'CODE';
+ }
+
+ $EVENTS->add_directive(@_);
+ return ();
+}
+
+sub intercept(&) {
+ my ($code) = @_;
+
+ my @events;
+
+ my ($ok, $error) = try {
+ Test::Stream->intercept(
+ sub {
+ my $stream = shift;
+ $stream->listen(
+ sub {
+ shift; # Stream
+ push @events => @_;
+ }
+ );
+ $code->();
+ }
+ );
+ };
+
+ die $error unless $ok || (blessed($error) && $error->isa('Test::Stream::Event'));
+
+ return \@events;
+}
+
+sub events_are {
+ my ($events, $checks, $name) = @_;
+
+ croak "Did not get any events"
+ unless $events;
+
+ croak "Did not get any checks"
+ unless $checks;
+
+ croak "checks must be an instance of Test::Stream::Tester::Checks"
+ unless blessed($checks)
+ && $checks->isa('Test::Stream::Tester::Checks');
+
+ my $ctx = context();
+
+ # use $_[0] directly so that the variable used in the method call can be undef'd
+ $events = $_[0]->finish
+ if blessed($events)
+ && $events->isa('Test::Stream::Tester::Grab');
+
+ $events = Test::Stream::Tester::Events->new(@$events)
+ if ref($events)
+ && reftype($events) eq 'ARRAY';
+
+ croak "'$events' is not a valid set of events."
+ unless $events
+ && blessed($events)
+ && $events->isa('Test::Stream::Tester::Events');
+
+ my ($ok, @diag) = $checks->run($events);
+
+ $ctx->ok($ok, $name, \@diag);
+ return $ok;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Tester - Tools for validating the events produced by your testing
+tools.
+
+=head1 DESCRIPTION
+
+There are tools to validate your code. This library provides tools to validate
+your tools!
+
+=head1 SYNOPSIS
+
+ use Test::More;
+ use Test::Stream::Tester;
+
+ events_are(
+ # Capture all the events within the block
+ intercept {
+ ok(1, "pass");
+ ok(0, "fail");
+ diag("xxx");
+ },
+
+ # Describe what we expect to see
+ check {
+ event ok => {bool => 1, name => 'pass'};
+ event ok => {
+ bool => 0,
+ name => 'fail',
+
+ # Ignores any fields in the result we don't list
+ # real_bool, line, file, tool_package, tool_name, etc...
+
+ # Diagnostics generated by a test are typically linked to those
+ # results (new and updated tools only) They can be validated.
+ diag => qr/^Failed test /,
+ };
+ event diag => {message => 'xxx'};
+ directive 'end'; # enforce that there are no more results
+ },
+
+ "This is the name of our test"
+ );
+
+ done_testing;
+
+=head2 GRAB WITH NO ADDED STACK
+
+ use Test::More;
+ use Test::Stream::Tester;
+
+ # Start capturing events. We use grab() instead of intercept {} to avoid
+ # adding stack frames.
+ my $grab = grab();
+
+ # Generate some events.
+ ok(1, "pass");
+ ok(0, "fail");
+ diag("xxx");
+
+ # Stop capturing events, and validate the ones recieved.
+ events_are(
+ $grab,
+ check {
+ event ok => { bool => 1, name => 'pass' };
+ event ok => { bool => 0, name => 'fail' };
+ event diag => { message => 'xxx' };
+ directive 'end';
+ },
+ 'Validate our Grab results';
+ );
+
+ # $grab is now undef, it no longer exists.
+ is($grab, undef, '$grab was destroyed for us.');
+
+ ok(!$success, "Eval did not succeed, BAIL_OUT killed the test");
+
+ # Make sure we got the event as an exception
+ isa_ok($error, 'Test::Stream::Event::Bail');
+
+ done_testing
+
+=head1 EXPORTS
+
+=over 4
+
+=item $events = intercept { ... }
+
+=item $events = intercept(sub { ... })
+
+Capture the L<Test::Builder::Event> objects generated by tests inside the block.
+
+=item events_are(\@events, $check)
+
+=item events_are(\@events, $check, $name)
+
+=item events_are($events, $check)
+
+=item events_are($events, $check, $name)
+
+=item events_are($grab, $check)
+
+=item events_are($grab, $check, $name)
+
+The first argument may be either an arrayref of L<Test::Stream::Event> objects,
+an L<Test::Stream::Tester::Grab> object, or an L<Test::Stream::Tester::Events>
+object. C<intercept { ... }> can be used to capture events within a block of
+code, including plans such as C<skip_all>, and things that normally kill the
+test like C<BAIL_OUT()>.
+
+The second argument must be an L<Test::Stream::Tester::Checks> object.
+Typically these are generated using C<check { ... }>.
+
+The third argument is the name of the test, it is optional, but highly
+recommended.
+
+=item $checks = check { ... };
+
+Produce an array of expected events for use in events_are.
+
+ my $check = check {
+ event ok => { ... };
+ event diag => { ... };
+ directive 'end';
+ };
+
+If the block passed to check returns anything at all it will warn you as this
+usually means you forgot to use the C<event> and/or C<diag> functions. If it
+returns something AND has no events it will be fatal.
+
+C<event()> and C<directive()> both return nothing, this means that if you use
+them alone your codeblock will return nothing.
+
+=item event TYPE => { ... };
+
+Define an event and push it onto the list that will be returned by the
+enclosing C<check { ... }> block. Will fail if run outside a check block. This
+will fail if you give it an invalid event type.
+
+If you wish to acknowledge the event, but not check anything you may simply
+give it an empty hashref.
+
+The line number where the event was generated is recorded for helpful debugging
+in event of a failure.
+
+B<CAVEAT> The line number is inexact because of the way perl records it. The
+line number is taken from C<caller>.
+
+=item dir 'DIRECTIVE';
+
+=item dir DIRECTIVE => 'ARG';
+
+=item dir sub { ... };
+
+=item dir sub { ... }, $arg;
+
+=item directive 'DIRECTIVE';
+
+=item directive DIRECTIVE => 'ARG';
+
+=item directive sub { ... };
+
+=item directive sub { ... }, $arg;
+
+Define a directive and push it onto the list that will be returned by the
+enclosing C<check { ... }> block. This will fail if run outside of a check
+block.
+
+The first argument must be either a codeblock, or one of the name of a
+predefined directive I<See the directives section>.
+
+Coderefs will be given 3 arguments:
+
+ sub {
+ my ($checks, $events, $arg) = @_;
+ ...
+ }
+
+C<$checks> is the L<Test::Stream::Tester::Checks> object. C<$events> is the
+L<Test::Stream::Tester::Events> object. C<$arg> is whatever argument you passed
+via the C<directive()> call.
+
+Most directives will act on the C<$events> object to remove or alter events.
+
+=back
+
+=head1 INTERCEPTING EVENTS
+
+ my $events = intercept {
+ ok(1, "pass");
+ ok(0, "fail");
+ diag("xxx");
+ };
+
+Any events generated within the block will be intercepted and placed inside
+the C<$events> array reference.
+
+=head2 EVENT TYPES
+
+All events will be subclasses of L<Test::Builder::Event>
+
+=over 4
+
+=item L<Test::Builder::Event::Ok>
+
+=item L<Test::Builder::Event::Note>
+
+=item L<Test::Builder::Event::Diag>
+
+=item L<Test::Builder::Event::Plan>
+
+=item L<Test::Builder::Event::Finish>
+
+=item L<Test::Builder::Event::Bail>
+
+=item L<Test::Builder::Event::Subtest>
+
+=back
+
+=head1 VALIDATING EVENTS
+
+You can validate events by hand using traditional test tools such as
+C<is_deeply()> against the $events array returned from C<intercept()>. However
+it is easier to use C<events_are()> paried with C<checks> objects build using
+C<checks { ... }>.
+
+ events_are(
+ intercept {
+ ok(1, "pass");
+ ok(0, "fail");
+ diag("xxx");
+ },
+
+ check {
+ event ok => { bool => 1, name => 'pass' };
+ event ok => { bool => 0, name => 'fail' };
+ event diag => {message => 'xxx'};
+ directive 'end';
+ },
+
+ "This is the name of our test"
+ );
+
+=head2 WHAT DOES THIS BUY ME?
+
+C<checks { ... }>, C<event()>, and C<directive()>, work together to produce a
+nested set of objects to represent what you want to see. This was chosen over a
+hash/list system for 2 reasons:
+
+=over 4
+
+=item Better Diagnostics
+
+Whenever you use C<checks { ... }>, C<events()>, and C<directive()> it records
+the filename and line number where they are called. When a test fails the
+diagnostics will include this information so that you know where the error
+occured. In a hash/list based system this information is not available.
+
+A hash based system is not practical as you may generate several events of the
+same type, and in a hash duplicated keys are squashed (last one wins).
+
+A list based system works, but then a failure reports the index of the failure,
+this requires you to manually count events to find the correct one. Originally
+I tried letting you specify an ID for the events, but this proved annoying.
+
+Ultimately I am very happy with the diagnostics this allows. It is very nice to
+see what is essentially a simple trace showing where the event and check were
+generated. It also shows you the items leading to the failure in the event of
+nested checks.
+
+=item Loops and other constructs
+
+In a list based system you are limited in what you can produce. You can
+generate the list in advance, then pass it in, but this is hard to debug.
+Alternatively you can use C<map> to produce repeated events, but this is
+equally hard to debug.
+
+This system lets you call C<event()> and C<directive()> in loops directly. It
+also lets you write functions that produce them based on input for reusable
+test code.
+
+=back
+
+=head2 VALIDATING FIELDS
+
+The hashref against which events are checked is composed of keys, and values.
+The values may be regular values, which are checked for equality with the
+corresponding property of the event object. Alternatively you can provide a
+regex to match against, or an arrayref of regexes (each one must match).
+
+=over 4
+
+=item field => 'exact_value',
+
+The specified field must exactly match the given value, be it number or string.
+
+=item field => qr/.../,
+
+The specified field must match the regular expression.
+
+=item field => [qr/.../, qr/.../, ...],
+
+The value of the field must match ALL the regexes.
+
+=item field => sub { ... }
+
+Specify a sub that will validate the value of the field.
+
+ foo => sub {
+ my ($key, $val) = @_;
+
+ ...
+
+ # Return true (valid) or false, and any desired diagnostics messages.
+ return($bool, @diag);
+ },
+
+=back
+
+=head2 WHAT FIELDS ARE AVAILABLE?
+
+This is specific to the event type. All events inherit from
+L<Test::Builder::Event> which provides a C<summary()> method. The C<summary()>
+method returns a list of key/value pairs I<(not a reference!)> with all fields
+that are for public consumption.
+
+For each of the following modules see the B<SUMMARY FIELDS> section for a list
+of fields made available. These fields are inherited when events are
+subclassed, and all events have the summary fields present in
+L<Test::Builder::Event>.
+
+=over 4
+
+=item L<Test::Builder::Event/"SUMMARY FIELDS">
+
+=item L<Test::Builder::Event::Ok/"SUMMARY FIELDS">
+
+=item L<Test::Builder::Event::Note/"SUMMARY FIELDS">
+
+=item L<Test::Builder::Event::Diag/"SUMMARY FIELDS">
+
+=item L<Test::Builder::Event::Plan/"SUMMARY FIELDS">
+
+=item L<Test::Builder::Event::Finish/"SUMMARY FIELDS">
+
+=item L<Test::Builder::Event::Bail/"SUMMARY FIELDS">
+
+=item L<Test::Builder::Event::Subtest/"SUMMARY FIELDS">
+
+=back
+
+=head2 DIRECTIVES
+
+Directives give you a chance to alter the list of events part-way through the
+check, or to make the check skip/ignore events based on conditions.
+
+=head3 skip
+
+Skip will skip a specific number of events at that point in the check.
+
+=over 4
+
+=item directive skip => $num;
+
+ my $events = intercept {
+ ok(1, "foo");
+ diag("XXX");
+
+ ok(1, "bar");
+ diag("YYY");
+
+ ok(1, "baz");
+ diag("ZZZ");
+ };
+
+ events_are(
+ $events,
+ ok => { name => "foo" },
+
+ skip => 1, # Skips the diag 'XXX'
+
+ ok => { name => "bar" },
+
+ skip => 2, # Skips the diag 'YYY' and the ok 'baz'
+
+ diag => { message => 'ZZZ' },
+ );
+
+=back
+
+=head3 seek
+
+When turned on (true), any unexpected events will be skipped. You can turn
+this on and off any time by using it again with a false argument.
+
+=over 4
+
+=item directive seek => $BOOL;
+
+ my $events = intercept {
+ ok(1, "foo");
+
+ diag("XXX");
+ diag("YYY");
+
+ ok(1, "bar");
+ diag("ZZZ");
+
+ ok(1, "baz");
+ };
+
+ events_are(
+ $events,
+
+ seek => 1,
+ ok => { name => "foo" },
+ # The diags are ignored, it will seek to the next 'ok'
+ ok => { name => "bar" },
+
+ seek => 0,
+
+ # This will fail because the diag is not ignored anymore.
+ ok => { name => "baz" },
+ );
+
+=back
+
+=head3 end
+
+Used to say that there should not be any more events. Without this any events
+after your last check are simply ignored. This will generate a failure if any
+unchecked events remain.
+
+=over 4
+
+=item directive 'end';
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Test::Tester> *Deprecated*
+
+A nice, but very limited tool for testing 'ok' results.
+
+=item L<Test::Builder::Tester> *Deprecated*
+
+The original test tester, checks TAP output as giant strings.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Tester::Checks;
+use strict;
+use warnings;
+
+use Test::Stream::Carp qw/croak confess/;
+use Test::Stream::Util qw/is_regex/;
+
+use Scalar::Util qw/blessed reftype/;
+
+my %DIRECTIVES = (
+ map { $_ => __PACKAGE__->can($_) }
+ qw(filter_providers filter_types skip seek end)
+);
+
+sub new {
+ my $class = shift;
+ my ($file, $line) = @_;
+ my $self = bless {
+ seek => 0,
+ items => [],
+ file => $file,
+ line => $line,
+ }, $class;
+ return $self;
+}
+
+sub debug {
+ my $self = shift;
+ return "Checks from $self->{file} around line $self->{line}.";
+}
+
+sub populated { scalar @{shift->{items}} }
+
+sub add_directive {
+ my $self = shift;
+ my ($dir, @args) = @_;
+
+ confess "No directive provided!"
+ unless $dir;
+
+ if (ref($dir)) {
+ confess "add_directive takes a coderef, or name, and optional args. (got $dir)"
+ unless reftype($dir) eq 'CODE';
+ }
+ else {
+ confess "$dir is not a valid directive."
+ unless $DIRECTIVES{$dir};
+ $dir = $DIRECTIVES{$dir};
+ }
+
+ push @{$self->{items}} => [$dir, @args];
+}
+
+sub add_event {
+ my $self = shift;
+ my ($type, $spec) = @_;
+
+ confess "add_event takes a type name and a hashref"
+ unless $type && $spec && ref $spec && reftype($spec) eq 'HASH';
+
+ my $e = Test::Stream::Tester::Checks::Event->new(%$spec, type => $type);
+ push @{$self->{items}} => $e;
+}
+
+sub include {
+ my $self = shift;
+ my ($other) = @_;
+
+ confess "Invalid argument to include()"
+ unless $other && blessed($other) && $other->isa(__PACKAGE__);
+
+ push @{$self->{items}} => @{$other->{items}};
+}
+
+sub run {
+ my $self = shift;
+ my ($events) = @_;
+ $events = $events->clone;
+
+ for (my $i = 0; $i < @{$self->{items}}; $i++) {
+ my $item = $self->{items}->[$i];
+
+ # Directive
+ if (reftype $item eq 'ARRAY') {
+ my ($code, @args) = @$item;
+ my @out = $self->$code($events, @args);
+ next unless @out;
+ return @out;
+ }
+
+ # Event!
+ my $meth = $self->{seek} ? 'seek' : 'next';
+ my $event = $events->$meth($item->get('type'));
+
+ my ($ret, @debug) = $self->check_event($item, $event);
+ return ($ret, @debug) unless $ret;
+ }
+
+ return (1);
+}
+
+sub vtype {
+ my ($v) = @_;
+
+ if (blessed($v)) {
+ return 'checks' if $v->isa('Test::Stream::Tester::Checks');
+ return 'events' if $v->isa('Test::Stream::Tester::Events');
+ return 'check' if $v->isa('Test::Stream::Tester::Checks::Event');
+ return 'event' if $v->isa('Test::Stream::Tester::Events::Event');
+ }
+
+ return 'regexp' if defined is_regex($v);
+ return 'noref' unless ref $v;
+ return 'array' if reftype($v) eq 'ARRAY';
+ return 'code' if reftype($v) eq 'CODE';
+
+ confess "Invalid field check: '$v'";
+}
+
+sub check_event {
+ my $self = shift;
+ my ($want, $got) = @_;
+
+ my @debug = (" Check: " . $want->debug);
+ my $wtype = $want->get('type');
+
+ return (0, @debug, " Expected event of type '$wtype', but did not find one.")
+ unless defined($got);
+
+ unshift @debug => " Event: " . $got->debug;
+ my $gtype = $got->get('type');
+
+ return (0, @debug, " Expected event of type '$wtype', but got '$gtype'.")
+ unless $wtype eq $gtype;
+
+ for my $key ($want->keys) {
+ my $wval = $want->get($key);
+ my $gval = $got->get($key);
+
+ my ($ret, @err) = $self->check_key($key, $wval, $gval);
+ return ($ret, @debug, @err) unless $ret;
+ }
+
+ return (1);
+}
+
+sub check_key {
+ my $self = shift;
+ my ($key, $wval, $gval) = @_;
+
+ if ((defined $wval) xor(defined $gval)) {
+ $wval = defined $wval ? "'$wval'" : 'undef';
+ $gval = defined $gval ? "'$gval'" : 'undef';
+ return (0, " \$got->{$key} = $gval", " \$exp->{$key} = $wval",);
+ }
+
+ my $wtype = vtype($wval);
+
+ my $meth = "_check_field_$wtype";
+ return $self->$meth($key, $wval, $gval);
+}
+
+sub _check_field_checks {
+ my $self = shift;
+ my ($key, $wval, $gval) = @_;
+
+ my $debug = $wval->debug;
+
+ return (0, " \$got->{$key} = '$gval'", " \$exp->{$key} = <$debug>")
+ unless vtype($gval) eq 'events';
+
+ my ($ret, @diag) = $wval->run($gval);
+ return $ret if $ret;
+ return ($ret, map { s/^/ /mg; $_ } @diag);
+}
+
+sub _check_field_check {
+ my $self = shift;
+ my ($key, $wval, $gval) = @_;
+
+ my $debug = $wval->debug;
+
+ return (0, "Event: INVALID EVENT ($gval)", " Check: $debug")
+ unless vtype($gval) eq 'event';
+
+ my ($ret, @diag) = check_event($wval, $gval);
+ return $ret if $ret;
+
+ return ($ret, map { s/^/ /mg; $_ } @diag);
+}
+
+sub _check_field_noref {
+ my $self = shift;
+ my ($key, $wval, $gval) = @_;
+
+ return (1) if !defined($wval) && !defined($gval);
+ return (1) if defined($wval) && defined($gval) && "$wval" eq "$gval";
+ $wval = "'$wval'" if defined $wval;
+ $wval ||= 'undef';
+ $gval = "'$gval'" if defined $gval;
+ $gval ||= 'undef';
+ return (0, " \$got->{$key} = $gval", " \$exp->{$key} = $wval");
+}
+
+sub _check_field_regexp {
+ my $self = shift;
+ my ($key, $wval, $gval) = @_;
+
+ return (1) if $gval =~ /$wval/;
+ return (0, " \$got->{$key} = '$gval'", " Does not match $wval");
+}
+
+sub _check_field_array {
+ my $self = shift;
+ my ($key, $wval, $gval) = @_;
+ for my $p (@$wval) {
+ my ($ret, @diag) = $self->_check_field_regexp($key, $p, $gval);
+ return ($ret, @diag) unless $ret;
+ }
+
+ return (1);
+}
+
+sub _check_field_code {
+ my $self = shift;
+ my ($key, $wval, $gval) = @_;
+ $wval->($key, $gval);
+}
+
+sub seek {
+ my $self = shift;
+ my ($events, $flag) = @_;
+
+ $self->{seek} = $flag ? 1 : 0;
+
+ return (); # Cannot fail
+}
+
+sub skip {
+ my $self = shift;
+ my ($events, $num) = @_;
+ $events->next while $num--;
+ return ();
+}
+
+sub end {
+ my $self = shift;
+ my ($events) = @_;
+ my $event = $events->next;
+ return () unless $event;
+ return (0, " Expected end of events, got " . $event->debug);
+}
+
+sub filter_providers {
+ my $self = shift;
+ my ($events, $arg) = @_;
+
+ my ($neg, $val) = $arg =~ m/^(!?)(.*)$/;
+ if ($neg) {
+ @$events = grep { $_->get('tool_package') ne $val } @$events;
+ }
+ else {
+ @$events = grep { $_->get('tool_package') eq $val } @$events;
+ }
+
+ return ();
+}
+
+sub filter_types {
+ my $self = shift;
+ my ($events, $arg) = @_;
+
+ my ($neg, $val) = $arg =~ m/^(!?)(.*)$/;
+ if ($neg) {
+ @$events = grep { $_->get('type') ne $val } @$events;
+ }
+ else {
+ @$events = grep { $_->get('type') eq $val } @$events;
+ }
+
+ return ();
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Tester::Checks - Representation of a L<Test::Stream::Tester>
+event check.
+
+=head1 DESCRIPTION
+
+L<Test::Stream::Tester> produces this object whenever you use C<check { ... }>.
+In general you will not interact with this object directly beyond pasing it
+into C<events_are>.
+
+B<Note:> The API for this object is not published and is subject to change. No backwords
+compatability can be guarenteed if you use this object directly. Please only
+use this object in the published way specified in L<Test::Stream::Tester>.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Tester::Checks::Event;
+use strict;
+use warnings;
+
+use Test::Stream::Util qw/is_regex/;
+use Test::Stream::Carp qw/confess croak/;
+
+use Scalar::Util qw/blessed reftype/;
+
+sub new {
+ my $class = shift;
+ my $fields = {@_};
+ my $self = bless {fields => $fields}, $class;
+
+ $self->{$_} = delete $fields->{$_}
+ for qw/debug_line debug_file debug_package/;
+
+ map { $self->validate_check($_) } values %$fields;
+
+ my $type = $self->get('type') || confess "No type specified!";
+
+ my $etypes = Test::Stream::Context->events;
+ confess "'$type' is not a valid event type"
+ unless $etypes->{$type};
+
+ return $self;
+}
+
+sub debug_line { shift->{debug_line} }
+sub debug_file { shift->{debug_file} }
+sub debug_package { shift->{debug_package} }
+
+sub debug {
+ my $self = shift;
+
+ my $type = $self->get('type');
+ my $file = $self->debug_file;
+ my $line = $self->debug_line;
+
+ return "'$type' from $file line $line.";
+}
+
+sub keys { sort keys %{shift->{fields}} }
+
+sub exists {
+ my $self = shift;
+ my ($field) = @_;
+ return exists $self->{fields}->{$field};
+}
+
+sub get {
+ my $self = shift;
+ my ($field) = @_;
+ return $self->{fields}->{$field};
+}
+
+sub validate_check {
+ my $self = shift;
+ my ($val) = @_;
+
+ return unless defined $val;
+ return unless ref $val;
+ return if defined is_regex($val);
+
+ if (blessed($val)) {
+ return if $val->isa('Test::Stream::Tester::Checks');
+ return if $val->isa('Test::Stream::Tester::Events');
+ return if $val->isa('Test::Stream::Tester::Checks::Event');
+ return if $val->isa('Test::Stream::Tester::Events::Event');
+ }
+
+ my $type = reftype($val);
+ return if $type eq 'CODE';
+
+ croak "'$val' is not a valid field check"
+ unless reftype($val) eq 'ARRAY';
+
+ croak "Arrayrefs given as field checks may only contain regexes"
+ if grep { ! defined is_regex($_) } @$val;
+
+ return;
+}
+
+1;
+
+=head1 NAME
+
+Test::Stream::Tester::Checks::Event - Representation of an event validation
+specification.
+
+=head1 DESCRIPTION
+
+Used internally by L<Test::Stream::Tester>. Please do not use directly. No
+backwords compatability will be provided if the API for this module changes.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Tester::Events;
+use strict;
+use warnings;
+
+use Scalar::Util qw/blessed/;
+
+use Test::Stream::Tester::Events::Event;
+
+sub new {
+ my $class = shift;
+ my $self = bless [map { Test::Stream::Tester::Events::Event->new($_->summary) } @_], $class;
+ return $self;
+}
+
+sub next { shift @{$_[0]} };
+
+sub seek {
+ my $self = shift;
+ my ($type) = @_;
+
+ while (my $e = shift @$self) {
+ return $e if $e->{type} eq $type;
+ }
+
+ return undef;
+}
+
+sub clone {
+ my $self = shift;
+ my $class = blessed($self);
+ return bless [@$self], $class;
+}
+
+1;
+
+=head1 NAME
+
+Test::Stream::Tester::Events - Event list used by L<Test::Stream::Tester>.
+
+=head1 DESCRIPTION
+
+L<Test::Stream::Tester> converts lists of events into instances of this object
+for use in various tools. You will probably never need to directly use this
+class.
+
+=head1 METHODS
+
+=over 4
+
+=item $events = $class->new(@EVENTS);
+
+Create a new instance from a list of events.
+
+=item $event = $events->next
+
+Get the next event.
+
+=item $event = $events->seek($type)
+
+Get the next event of the specific type (not a package name).
+
+=item $copy = $events->clone()
+
+Clone the events list object in its current state.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Tester::Events::Event;
+use strict;
+use warnings;
+
+use Test::Stream::Carp qw/confess/;
+use Scalar::Util qw/reftype blessed/;
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+
+ my @orig = @_;
+
+ while (@_) {
+ my $field = shift;
+ my $val = shift;
+
+ if (exists $self->{$field}) {
+ use Data::Dumper;
+ print Dumper(@orig);
+ confess "'$field' specified more than once!";
+ }
+
+ if (my $type = reftype $val) {
+ if ($type eq 'ARRAY') {
+ $val = Test::Stream::Tester::Events->new(@$val)
+ unless grep { !blessed($_) || !$_->isa('Test::Stream::Event') } @$val;
+ }
+ elsif (blessed($val) && $val->isa('Test::Stream::Event')) {
+ $val = $class->new($val->summary);
+ }
+ }
+
+ $self->{$field} = $val;
+ }
+
+ return $self;
+}
+
+sub get {
+ my $self = shift;
+ my ($field) = @_;
+ return $self->{$field};
+}
+
+sub debug {
+ my $self = shift;
+
+ my $type = $self->get('type');
+ my $file = $self->get('file');
+ my $line = $self->get('line');
+
+ return "'$type' from $file line $line.";
+}
+
+1;
+
+=head1 NAME
+
+Test::Stream::Tester::Events::Event - L<Test::Stream::Tester> representation of
+an event.
+
+=head1 DESCRIPTION
+
+L<Test::Stream::Tester> often uses this clas to represent events in a way that
+is easier to validate.
+
+=head1 SYNOPSYS
+
+ use Test::Stream::Tester::Events::Event;
+
+ my $event = Test::Stream::Tester::Events::Event->new($e->summary);
+
+ # Print the file and line number where the event was generated
+ print "Debug: " . $event->debug . "\n";
+
+ # Get an event field value
+ my $val = $event->get($field);
+
+=head1 METHODS
+
+=over 4
+
+=item $event->get($field)
+
+Get the value of a specific event field. Fields are specific to event types.
+The fields are usually the result of calling C<< $e->summary >> on the original
+event.
+
+=item $event->debug
+
+Returns a string like this:
+
+ 'ok' from my_test.t line 42.
+
+Which lists the type of event, the file that generated, and the line number on
+which it was generated.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Tester::Grab;
+use strict;
+use warnings;
+
+sub new {
+ my $class = shift;
+
+ my $self = bless {
+ events => [],
+ streams => [ Test::Stream->intercept_start ],
+ }, $class;
+
+ $self->{streams}->[0]->listen(
+ sub {
+ shift; # Stream
+ push @{$self->{events}} => @_;
+ }
+ );
+
+ return $self;
+}
+
+sub flush {
+ my $self = shift;
+ my $out = delete $self->{events};
+ $self->{events} = [];
+ return $out;
+}
+
+sub events {
+ my $self = shift;
+ # Copy
+ return [@{$self->{events}}];
+}
+
+sub finish {
+ my ($self) = @_; # Do not shift;
+ $_[0] = undef;
+
+ $self->{finished} = 1;
+ my ($remove) = $self->{streams}->[0];
+ Test::Stream->intercept_stop($remove);
+
+ return $self->flush;
+}
+
+sub DESTROY {
+ my $self = shift;
+ return if $self->{finished};
+ my ($remove) = $self->{streams}->[0];
+ Test::Stream->intercept_stop($remove);
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Test::Stream::Tester::Grab - Object used to temporarily steal all events.
+
+=head1 DESCRIPTION
+
+Once created this object will intercept and stash all events sent to the shared
+L<Test::Stream> object. Once the object is destroyed events will once again be
+sent to the shared stream.
+
+=head1 SYNOPSYS
+
+ use Test::More;
+ use Test::Stream::Tester::Grab;
+
+ my $grab = Test::Stream::Tester::Grab->new();
+
+ # Generate some events, they are intercepted.
+ ok(1, "pass");
+ ok(0, "fail");
+
+ my $events_a = $grab->flush;
+
+ # Generate some more events, they are intercepted.
+ ok(1, "pass");
+ ok(0, "fail");
+
+ # Same as flush, except it destroys the grab object.
+ my $events_b = $grab->finish;
+
+After calling C<finish()> the grab object is destroyed and C<$grab> is set to
+undef. C<$events_a> is an arrayref with the first 2 events. C<$events_b> is an
+arrayref with the second 2 events.
+
+=head1 METHODS
+
+=over 4
+
+=item $grab = $class->new()
+
+Create a new grab object, immediately starts intercepting events.
+
+=item $ar = $grab->flush()
+
+Get an arrayref of all the events so far, clearing the grab objects internal
+list.
+
+=item $ar = $grab->events()
+
+Get an arrayref of all events so far, does not clear the internal list.
+
+=item $ar = $grab->finish()
+
+Get an arrayref of all the events, then destroy the grab object.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Threads;
+use strict;
+use warnings;
+
+BEGIN {
+ use Config;
+ if( $Config{useithreads} && $INC{'threads.pm'} ) {
+ eval q|
+ sub get_tid { threads->tid() }
+ sub USE_THREADS() { 1 }
+ 1;
+ | || die $@;
+ }
+ else {
+ eval q|
+ sub get_tid() { 0 }
+ sub USE_THREADS() { 0 }
+ 1;
+ | || die $@;
+ }
+}
+
+use Test::Stream::Exporter;
+default_exports qw/get_tid USE_THREADS/;
+Test::Stream::Exporter->cleanup;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Threads - Tools for using threads with Test::Stream.
+
+=head1 DESCRIPTION
+
+This module provides some helpers for Test::Stream and Toolsets to use to
+determine if threading is in place. In most cases you will not need to use this
+module yourself.
+
+=head1 SYNOPSYS
+
+ use threads;
+ use Test::Stream::Threads;
+
+ if (USE_THREADS) {
+ my $tid = get_tid();
+ }
+
+=head1 EXPORTS
+
+=over 4
+
+=item USE_THREADS
+
+This is a constant, it is set to true when Test::Stream is aware of, and using, threads.
+
+=item get_tid
+
+This will return the id of the current thread when threads are enabled,
+otherwise it returns 0.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Toolset;
+use strict;
+use warnings;
+
+use Test::Stream::Context qw/context/;
+use Test::Stream::Meta qw/is_tester init_tester/;
+
+# Preload these so the autoload is not necessary
+use Test::Stream::Event::Bail;
+use Test::Stream::Event::Child;
+use Test::Stream::Event::Diag;
+use Test::Stream::Event::Finish;
+use Test::Stream::Event::Note;
+use Test::Stream::Event::Ok;
+use Test::Stream::Event::Plan;
+use Test::Stream::Event::Subtest;
+
+use Test::Stream::Exporter qw/import export_to default_exports/;
+default_exports qw/is_tester init_tester context/;
+Test::Stream::Exporter->cleanup();
+
+1;
+
+=head1 NAME
+
+Test::Stream::Toolset - Helper for writing testing tools
+
+=head1 DESCRIPTION
+
+This package provides you with tools to write testing tools. It makes your job
+of integrating with L<Test::Builder> and other testing tools much easier.
+
+=head1 SYNOPSYS
+
+ package My::Tester;
+ use strict;
+ use warnings;
+ use Test::Stream::Toolset;
+
+ # Optional, you can just use Exporter if you would like
+ use Test::Stream::Exporter;
+
+ # These can come from Test::More, so do not export them by default
+ # exports is the Test::Stream::Exporter equivilent to @EXPORT_OK
+ exports qw/context done_testing/;
+
+ # These are the API we want to provide, export them by default
+ # default_exports is the Test::Stream::Exporter equivilent to @EXPORT
+ default_exports qw/my_ok my_note/;
+
+ sub my_ok {
+ my ($test, $name) = @_;
+ my $ctx = context();
+
+ my @diag;
+ push @diag => "'$test' is not true!" unless $test;
+
+ $ctx->ok($test, $name, \@diag);
+
+ return $test ? 1 : 0; # Reduce to a boolean
+ }
+
+ sub my_note {
+ my ($msg) = @_;
+ my $ctx = context();
+
+ $ctx->note($msg);
+
+ return $msg;
+ }
+
+ sub done_testing {
+ my ($expected) = @_;
+ my $ctx = context();
+ $ctx->done_testing($expected);
+ }
+
+ 1;
+
+=head1 EXPORTS
+
+=over 4
+
+=item $ctx = context()
+
+The context() method is used to get the current context, generating one if
+necessary. The context object is an instance of L<Test::Stream::Context>, and
+is used to generate events suck as C<ok> and C<plan>. The context also knows
+what file+line errors should be reported at.
+
+B<WARNING:> Do not directly store the context in anything other than a lexical
+variable scoped to your function! As long as there are references to a context
+object, C<context()> will return that object. You want the object to be
+destroyed at the end of the current scope so that the next function you call
+can create a new one. If you need a copy of the context use
+C<< $ctx = $ctx->snapshot >>.
+
+=item $meta = init_tester($CLASS)
+
+This method can be used to initialize a class as a test class. In most cases
+you do not actually need to use this. If the class is already a tester this
+will return the existing meta object.
+
+=item $meta = is_tester($CLASS)
+
+This method can be used to check if an object is a tester. If the object is a
+tester it will return the meta object for the tester.
+
+=back
+
+=head1 GENERATING EVENTS
+
+Events are always generated via a context object. Whenever you load an
+L<Test::Stream::Event> class it will add a method to L<Test::Stream::Context>
+which can be used to fire off that type of event.
+
+The following event types are all loaded automatically by
+L<Test::Stream::Toolset>
+
+=over 4
+
+=item L<Test::Stream::Event::Ok>
+
+ $ctx->ok($bool, $name, \@diag)
+
+Ok events are your actual assertions. You assert that a condition is what you
+expect. It is recommended that you name your assertions. You can include an
+array of diag objects and/or diagniostics strings that will be printed to
+STDERR as comments in the event of a failure.
+
+=item L<Test::Stream::Event::Diag>
+
+ $ctx->diag($MESSAGE)
+
+Produce an independant diagnostics message.
+
+=item L<Test::Stream::Event::Note>
+
+ $ctx->note($MESSAGE)
+
+Produce a note, that is a message that is printed to STDOUT as a comment.
+
+=item L<Test::Stream::Event::Plan>
+
+ $ctx->plan($MAX, $DIRECTIVE, $REASON)
+
+This will set the plan. C<$MAX> should be the number of tests you expect to
+run. You may set this to 0 for some plan directives. Examples of directives are
+C<'skip_all'> and C<'no_plan'>. Some directives have an additional argument
+called C<$REASON> which is aptly named as the reason for the directive.
+
+=item L<Test::Stream::Event::Bail>
+
+ $ctx->bail($MESSAGE)
+
+In the event of a catostrophic failure that should terminate the test file, use
+this event to stop everything and print the reason.
+
+=item L<Test::Stream::Event::Finish>
+
+=item L<Test::Stream::Event::Child>
+
+=item L<Test::Stream::Event::Subtest>
+
+These are not intended for public use, but are documented for completeness.
+
+=back
+
+=head1 MODIFYING EVENTS
+
+If you want to make changes to event objects before they are processed, you can
+add a munger. The return from a munger is ignored, you must make your changes
+directly to the event object.
+
+ Test::Stream->shared->munge(sub {
+ my ($stream, $event) = @_;
+ ...
+ });
+
+B<Note:> every munger is called for every event of every type. There is also no
+way to remove a munger. For performance reasons it is best to only ever add one
+munger per toolset which dispatches according to events and state.
+
+=head1 LISTENING FOR EVENTS
+
+If you wish to know when an event has occured so that you can do something
+after it has been processed, you can add a listener. Your listener will be
+called for every single event that occurs, after it has been processed. The
+return from a listener is ignored.
+
+ Test::Stream->shared->listen(sub {
+ my ($stream, $event) = @_;
+ ...
+ });
+
+B<Note:> every listener is called for every event of every type. There is also no
+way to remove a listener. For performance reasons it is best to only ever add one
+listener per toolset which dispatches according to events and state.
+
+=head1 I WANT TO EMBED FUNCTIONALITY FROM TEST::MORE
+
+Take a look at L<Test::More::Tools> which provides an interfaces to the code in
+Test::More. You can use that library to produce booleans and diagnostics
+without actually triggering events, giving you the opportunity to generate your
+own.
+
+=head1 FROM TEST::BUILDER TO TEST::STREAM
+
+This is a list of things people used to override in Test::Builder, and the new
+API that should be used instead of overrides.
+
+=over 4
+
+=item ok
+
+=item note
+
+=item diag
+
+=item plan
+
+In the past people would override these methods on L<Test::Builder>.
+L<Test::Stream> now provides a proper API for handling all event types.
+
+Anything that used to be done via overrides can now be done using
+c<Test::Stream->shared->listen(sub { ... })> and
+C<Test::Stream->shared->munge(sub { ... })>, which are documented above.
+
+=item done_testing
+
+In the past people have overriden C<done_testing()> to insert some code between
+the last test and the final plan. The proper way to do this now is with a
+follow_up hook.
+
+ Test::Stream->shared->follow_up(sub {
+ my ($context) = @_;
+ ...
+ });
+
+There are multiple ways that follow_ups will be triggered, but they are
+guarenteed to only be called once, at the end of testing. This will either be
+the start of C<done_testing()>, or an END block called after your tests are
+complete.
+
+=back
+
+=head1 HOW DO I TEST MY TEST TOOLS?
+
+See L<Test::Stream::Tester>. This library gives you all the tools you need to
+test your testing tools.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Stream::Util;
+use strict;
+use warnings;
+
+use Scalar::Util qw/reftype blessed/;
+use Test::Stream::Exporter qw/import export_to exports/;
+use Test::Stream::Carp qw/croak/;
+
+exports qw{
+ try protect spoof is_regex is_dualvar
+ unoverload unoverload_str unoverload_num
+ translate_filename
+};
+
+Test::Stream::Exporter->cleanup();
+
+sub protect(&) {
+ my $code = shift;
+
+ my ($ok, $error);
+ {
+ local ($@, $!);
+ $ok = eval { $code->(); 1 } || 0;
+ $error = $@ || "Error was squashed!\n";
+ }
+ die $error unless $ok;
+ return $ok;
+}
+
+sub try(&) {
+ my $code = shift;
+ my $error;
+ my $ok;
+
+ {
+ local ($@, $!, $SIG{__DIE__});
+ $ok = eval { $code->(); 1 } || 0;
+ unless($ok) {
+ $error = $@ || "Error was squashed!\n";
+ }
+ }
+
+ return wantarray ? ($ok, $error) : $ok;
+}
+
+sub spoof {
+ my ($call, $code, @args) = @_;
+
+ croak "The first argument to spoof must be an arrayref with package, filename, and line."
+ unless $call && @$call == 3;
+
+ croak "The second argument must be a string to run."
+ if ref $code;
+
+ my $error;
+ my $ok;
+
+ {
+ local ($@, $!);
+ $ok = eval <<" EOT" || 0;
+package $call->[0];
+#line $call->[2] "$call->[1]"
+$code;
+1;
+ EOT
+ unless($ok) {
+ $error = $@ || "Error was squashed!\n";
+ }
+ }
+
+ return wantarray ? ($ok, $error) : $ok;
+}
+
+sub is_regex {
+ my ($pattern) = @_;
+
+ return undef unless defined $pattern;
+
+ return $pattern if defined &re::is_regexp
+ && re::is_regexp($pattern);
+
+ my $type = reftype($pattern) || '';
+
+ return $pattern if $type =~ m/^regexp?$/i;
+ return $pattern if $type eq 'SCALAR' && $pattern =~ m/^\(\?.+:.*\)$/s;
+ return $pattern if !$type && $pattern =~ m/^\(\?.+:.*\)$/s;
+
+ my ($re, $opts);
+
+ if ($pattern =~ m{^ /(.*)/ (\w*) $ }sx) {
+ protect { ($re, $opts) = ($1, $2) };
+ }
+ elsif ($pattern =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx) {
+ protect { ($re, $opts) = ($2, $3) };
+ }
+ else {
+ return;
+ }
+
+ return length $opts ? "(?$opts)$re" : $re;
+}
+
+sub unoverload_str { unoverload(q[""], @_) }
+
+sub unoverload_num {
+ unoverload('0+', @_);
+
+ for my $val (@_) {
+ next unless is_dualvar($$val);
+ $$val = $$val + 0;
+ }
+
+ return;
+}
+
+# This is a hack to detect a dualvar such as $!
+sub is_dualvar($) {
+ my($val) = @_;
+
+ # Objects are not dualvars.
+ return 0 if ref $val;
+
+ no warnings 'numeric';
+ my $numval = $val + 0;
+ return ($numval != 0 and $numval ne $val ? 1 : 0);
+}
+
+## If Scalar::Util is new enough use it
+# This breaks cmp_ok diagnostics
+#if (my $sub = Scalar::Util->can('isdual')) {
+# no warnings 'redefine';
+# *is_dualvar = $sub;
+#}
+
+sub unoverload {
+ my $type = shift;
+
+ protect { require overload };
+
+ for my $thing (@_) {
+ if (blessed $$thing) {
+ if (my $string_meth = overload::Method($$thing, $type)) {
+ $$thing = $$thing->$string_meth();
+ }
+ }
+ }
+}
+
+my $NORMALIZE = undef;
+sub translate_filename {
+ my ($encoding, $orig) = @_;
+
+ return $orig if $encoding eq 'legacy';
+
+ my $decoded;
+ require Encode;
+ try { $decoded = Encode::decode($encoding, "$orig", Encode::FB_CROAK()) };
+ return $orig unless $decoded;
+
+ unless (defined $NORMALIZE) {
+ $NORMALIZE = try { require Unicode::Normalize; 1 };
+ $NORMALIZE ||= 0;
+ }
+ $decoded = Unicode::Normalize::NFKC($decoded) if $NORMALIZE;
+ return $decoded || $orig;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Stream::Util - Tools used by Test::Stream and friends.
+
+=head1 DESCRIPTION
+
+Collection of tools used by L<Test::Stream> and friends.
+
+=head1 EXPORTS
+
+=over 4
+
+=item $success = try { ... }
+
+=item ($success, $error) = try { ... }
+
+Eval the codeblock, return success or failure, and optionally the error
+message. This code protects $@ and $!, they will be restored by the end of the
+run. This code also temporarily blocks $SIG{DIE} handlers.
+
+=item protect { ... }
+
+Similar to try, except that it does not catch exceptions. The idea here is to
+protect $@ and $! from changes. $@ and $! will be restored to whatever they
+were before the run so long as it is successful. If the run fails $! will still
+be restored, but $@ will contain the exception being thrown.
+
+=item spoof([$package, $file, $line], "Code String", @args)
+
+Eval the string provided as the second argument pretending to be the specified
+package, file, and line number. The main purpose of this is to have warnings
+and exceptions be thrown from the desired context.
+
+Additional arguments will be added to an C<@args> variable that is available to
+you inside your code string.
+
+=item $usable_pattern = is_regex($PATTERN)
+
+Check of the specified argument is a regex. This is mainly important in older
+perls where C<qr//> did not work the way it does now.
+
+=item is_dualvar
+
+Do not use this, use Scalar::Util::isdual instead. This is kept around for
+legacy support.
+
+=item unoverload
+
+=item unoverload_str
+
+=item unoverload_num
+
+Legacy tools for unoverloading things.
+
+=item $proper = translate_filename($encoding, $raw)
+
+Translate filenames from whatever perl has them stored as into the proper,
+specified, encoding.
+
+=back
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+use strict;
+
+package Test::Tester;
+
+# Turn this back on later
+#warn "Test::Tester is deprecated, see Test::Stream::Tester\n";
+
+use Test::Stream 1.301001 '-internal';
+use Test::Builder 1.301001;
+use Test::Stream::Toolset;
+use Test::More::Tools;
+use Test::Stream qw/-internal STATE_LEGACY/;
+use Test::Tester::Capture;
+
+require Exporter;
+
+use vars qw( @ISA @EXPORT $VERSION );
+
+our $VERSION = '1.301001_075';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+@EXPORT = qw( run_tests check_tests check_test cmp_results show_space );
+@ISA = qw( Exporter );
+
+my $want_space = $ENV{TESTTESTERSPACE};
+
+sub show_space {
+ $want_space = 1;
+}
+
+my $colour = '';
+my $reset = '';
+
+if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOUR}) {
+ if (eval "require Term::ANSIColor") {
+ my ($f, $b) = split(",", $want_colour);
+ $colour = Term::ANSIColor::color($f) . Term::ANSIColor::color("on_$b");
+ $reset = Term::ANSIColor::color("reset");
+ }
+
+}
+
+my $capture = Test::Tester::Capture->new;
+sub capture { $capture }
+
+sub find_depth {
+ my ($start, $end);
+ my $l = 1;
+ while (my @call = caller($l++)) {
+ $start = $l if $call[3] =~ m/^Test::Builder::(ok|skip|todo_skip)$/;
+ next unless $start;
+ next unless $call[3] eq 'Test::Tester::run_tests';
+ $end = $l;
+ last;
+ }
+
+ return $Test::Builder::Level + 1 unless defined $start && defined $end;
+ # 2 the eval and the anon sub
+ return $end - $start - 2;
+}
+
+require Test::Stream::Event::Ok;
+my $META = Test::Stream::ArrayBase::Meta->get('Test::Stream::Event::Ok');
+my $idx = $META->{index} + 1;
+
+sub run_tests {
+ my $test = shift;
+
+ my $cstream;
+ if ($capture) {
+ $cstream = $capture->{stream};
+ }
+
+ my ($stream, $old) = Test::Stream->intercept_start($cstream);
+ $stream->set_use_legacy(1);
+ $stream->state->[-1] = [0, 0, undef, 1];
+ $stream->munge(sub {
+ my ($stream, $e) = @_;
+ $e->[$idx] = find_depth() - $Test::Builder::Level;
+ $e->[$idx+1] = $Test::Builder::Level;
+ require Carp;
+ $e->[$idx + 2] = Carp::longmess();
+ });
+
+ my $level = $Test::Builder::Level;
+
+ my @out;
+ my $prem = "";
+
+ my $ok = eval {
+ $test->();
+
+ for my $e (@{$stream->state->[-1]->[STATE_LEGACY]}) {
+ if ($e->isa('Test::Stream::Event::Ok')) {
+ push @out => $e->to_legacy;
+ $out[-1]->{name} = '' unless defined $out[-1]->{name};
+ $out[-1]->{diag} ||= "";
+ $out[-1]->{depth} = $e->[$idx];
+ for my $d (@{$e->diag || []}) {
+ next if $d->message =~ m{Failed (\(TODO\) )?test (.*\n\s*)?at .* line \d+\.};
+ next if $d->message =~ m{You named your test '.*'\. You shouldn't use numbers for your test names};
+ chomp(my $msg = $d->message);
+ $msg .= "\n";
+ $out[-1]->{diag} .= $msg;
+ }
+ }
+ elsif ($e->isa('Test::Stream::Event::Diag')) {
+ chomp(my $msg = $e->message);
+ $msg .= "\n";
+ if (!@out) {
+ $prem .= $msg;
+ next;
+ }
+ next if $msg =~ m{Failed test .*\n\s*at .* line \d+\.};
+ $out[-1]->{diag} .= $msg;
+ }
+ }
+
+ 1;
+ };
+ my $err = $@;
+
+ $stream->state->[-1] = [0, 0, undef, 1];
+
+ Test::Stream->intercept_stop($stream);
+
+ die $err unless $ok;
+
+ return ($prem, @out);
+}
+
+sub check_test {
+ my $test = shift;
+ my $expect = shift;
+ my $name = shift;
+ $name = "" unless defined($name);
+
+ @_ = ($test, [$expect], $name);
+ goto &check_tests;
+}
+
+sub check_tests {
+ my $test = shift;
+ my $expects = shift;
+ my $name = shift;
+ $name = "" unless defined($name);
+
+ my ($prem, @results) = eval { run_tests($test, $name) };
+
+ my $ctx = context();
+
+ my $ok = !$@;
+ $ctx->ok($ok, "Test '$name' completed");
+ $ctx->diag($@) unless $ok;
+
+ $ok = !length($prem);
+ $ctx->ok($ok, "Test '$name' no premature diagnostication");
+ $ctx->diag("Before any testing anything, your tests said\n$prem") unless $ok;
+
+ cmp_results(\@results, $expects, $name);
+ return ($prem, @results);
+}
+
+sub cmp_field {
+ my ($result, $expect, $field, $desc) = @_;
+
+ my $ctx = context();
+ if (defined $expect->{$field}) {
+ my ($ok, @diag) = Test::More::Tools->is_eq(
+ $result->{$field},
+ $expect->{$field},
+ );
+ $ctx->ok($ok, "$desc compare $field");
+ }
+}
+
+sub cmp_result {
+ my ($result, $expect, $name) = @_;
+
+ my $ctx = context();
+
+ my $sub_name = $result->{name};
+ $sub_name = "" unless defined($name);
+
+ my $desc = "subtest '$sub_name' of '$name'";
+
+ {
+ cmp_field($result, $expect, "ok", $desc);
+
+ cmp_field($result, $expect, "actual_ok", $desc);
+
+ cmp_field($result, $expect, "type", $desc);
+
+ cmp_field($result, $expect, "reason", $desc);
+
+ cmp_field($result, $expect, "name", $desc);
+ }
+
+ # if we got no depth then default to 1
+ my $depth = 1;
+ if (exists $expect->{depth}) {
+ $depth = $expect->{depth};
+ }
+
+ # if depth was explicitly undef then don't test it
+ if (defined $depth) {
+ $ctx->ok(1, "depth checking is deprecated, dummy pass result...");
+ }
+
+ if (defined(my $exp = $expect->{diag})) {
+ # if there actually is some diag then put a \n on the end if it's not
+ # there already
+
+ $exp .= "\n" if (length($exp) and $exp !~ /\n$/);
+ my $ok = $result->{diag} eq $exp;
+ $ctx->ok(
+ $ok,
+ "subtest '$sub_name' of '$name' compare diag"
+ );
+ unless($ok) {
+ my $got = $result->{diag};
+ my $glen = length($got);
+ my $elen = length($exp);
+ for ($got, $exp) {
+ my @lines = split("\n", $_);
+ $_ = join(
+ "\n",
+ map {
+ if ($want_space) {
+ $_ = $colour . escape($_) . $reset;
+ }
+ else {
+ "'$colour$_$reset'";
+ }
+ } @lines
+ );
+ }
+
+ $ctx->diag(<<EOM);
+Got diag ($glen bytes):
+$got
+Expected diag ($elen bytes):
+$exp
+EOM
+
+ }
+ }
+}
+
+sub escape {
+ my $str = shift;
+ my $res = '';
+ for my $char (split("", $str)) {
+ my $c = ord($char);
+ if (($c > 32 and $c < 125) or $c == 10) {
+ $res .= $char;
+ }
+ else {
+ $res .= sprintf('\x{%x}', $c);
+ }
+ }
+ return $res;
+}
+
+sub cmp_results {
+ my ($results, $expects, $name) = @_;
+
+ my $ctx = context();
+
+ my ($ok, @diag) = Test::More::Tools->is_num(scalar @$results, scalar @$expects, "Test '$name' result count");
+ $ctx->ok($ok, @diag);
+
+ for (my $i = 0; $i < @$expects; $i++) {
+ my $expect = $expects->[$i];
+ my $result = $results->[$i];
+
+ cmp_result($result, $expect, $name);
+ }
+}
+
+######## nicked from Test::More
+sub import {
+ my $class = shift;
+ my @plan = @_;
+
+ my $caller = caller;
+ my $ctx = context();
+
+ my @imports = ();
+ foreach my $idx (0 .. $#plan) {
+ if ($plan[$idx] eq 'import') {
+ my ($tag, $imports) = splice @plan, $idx, 2;
+ @imports = @$imports;
+ last;
+ }
+ }
+
+ my ($directive, $arg) = @plan;
+ if ($directive eq 'tests') {
+ $ctx->plan($arg);
+ }
+ elsif ($directive) {
+ $ctx->plan(0, $directive, $arg);
+ }
+
+ $class->_export_to_level(1, __PACKAGE__, @imports);
+}
+
+sub _export_to_level {
+ my $pkg = shift;
+ my $level = shift;
+ (undef) = shift; # redundant arg
+ my $callpkg = caller($level);
+ $pkg->export($callpkg, @_);
+}
+
+############
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Tester - *DEPRECATED* Ease testing test modules built with Test::Builder
+
+=head1 DEPRECATED
+
+See L<Test::Stream::Tester> for a modern and maintained alternative.
+
+=head1 SYNOPSIS
+
+ use Test::Tester tests => 6;
+
+ use Test::MyStyle;
+
+ check_test(
+ sub {
+ is_mystyle_eq("this", "that", "not eq");
+ },
+ {
+ ok => 0, # expect this to fail
+ name => "not eq",
+ diag => "Expected: 'this'\nGot: 'that'",
+ }
+ );
+
+or
+
+ use Test::Tester;
+
+ use Test::More tests => 3;
+ use Test::MyStyle;
+
+ my ($premature, @results) = run_tests(
+ sub {
+ is_database_alive("dbname");
+ }
+ );
+
+ # now use Test::More::like to check the diagnostic output
+
+ like($results[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag");
+
+=head1 DESCRIPTION
+
+If you have written a test module based on Test::Builder then Test::Tester
+allows you to test it with the minimum of effort.
+
+=head1 HOW TO USE (THE EASY WAY)
+
+From version 0.08 Test::Tester no longer requires you to included anything
+special in your test modules. All you need to do is
+
+ use Test::Tester;
+
+in your test script B<before> any other Test::Builder based modules and away
+you go.
+
+Other modules based on Test::Builder can be used to help with the
+testing. In fact you can even use functions from your module to test
+other functions from the same module (while this is possible it is
+probably not a good idea, if your module has bugs, then
+using it to test itself may give the wrong answers).
+
+The easiest way to test is to do something like
+
+ check_test(
+ sub { is_mystyle_eq("this", "that", "not eq") },
+ {
+ ok => 0, # we expect the test to fail
+ name => "not eq",
+ diag => "Expected: 'this'\nGot: 'that'",
+ }
+ );
+
+this will execute the is_mystyle_eq test, capturing it's results and
+checking that they are what was expected.
+
+You may need to examine the test results in a more flexible way, for
+example, the diagnostic output may be quite long or complex or it may involve
+something that you cannot predict in advance like a timestamp. In this case
+you can get direct access to the test results:
+
+ my ($premature, @results) = run_tests(
+ sub {
+ is_database_alive("dbname");
+ }
+ );
+
+ like($result[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag");
+
+
+We cannot predict how long the database ping will take so we use
+Test::More's like() test to check that the diagnostic string is of the right
+form.
+
+=head1 HOW TO USE (THE HARD WAY)
+
+I<This is here for backwards compatibility only>
+
+Make your module use the Test::Tester::Capture object instead of the
+Test::Builder one. How to do this depends on your module but assuming that
+your module holds the Test::Builder object in $Test and that all your test
+routines access it through $Test then providing a function something like this
+
+ sub set_builder
+ {
+ $Test = shift;
+ }
+
+should allow your test scripts to do
+
+ Test::YourModule::set_builder(Test::Tester->capture);
+
+and after that any tests inside your module will captured.
+
+=head1 TEST EVENTS
+
+The result of each test is captured in a hash. These hashes are the same as
+the hashes returned by Test::Builder->details but with a couple of extra
+fields.
+
+These fields are documented in L<Test::Builder> in the details() function
+
+=over 2
+
+=item ok
+
+Did the test pass?
+
+=item actual_ok
+
+Did the test really pass? That is, did the pass come from
+Test::Builder->ok() or did it pass because it was a TODO test?
+
+=item name
+
+The name supplied for the test.
+
+=item type
+
+What kind of test? Possibilities include, skip, todo etc. See
+L<Test::Builder> for more details.
+
+=item reason
+
+The reason for the skip, todo etc. See L<Test::Builder> for more details.
+
+=back
+
+These fields are exclusive to Test::Tester.
+
+=over 2
+
+=item diag
+
+Any diagnostics that were output for the test. This only includes
+diagnostics output B<after> the test result is declared.
+
+Note that Test::Builder ensures that any diagnostics end in a \n and
+it in earlier versions of Test::Tester it was essential that you have
+the final \n in your expected diagnostics. From version 0.10 onwards,
+Test::Tester will add the \n if you forgot it. It will not add a \n if
+you are expecting no diagnostics. See below for help tracking down
+hard to find space and tab related problems.
+
+=item depth
+
+B<Note:> Depth checking is disabled on newer versions of Test::Builder which no
+longer uses $Test::Builder::Level. In these versions this will simple produce a
+dummy true result.
+
+This allows you to check that your test module is setting the correct value
+for $Test::Builder::Level and thus giving the correct file and line number
+when a test fails. It is calculated by looking at caller() and
+$Test::Builder::Level. It should count how many subroutines there are before
+jumping into the function you are testing. So for example in
+
+ run_tests( sub { my_test_function("a", "b") } );
+
+the depth should be 1 and in
+
+ sub deeper { my_test_function("a", "b") }
+
+ run_tests(sub { deeper() });
+
+depth should be 2, that is 1 for the sub {} and one for deeper(). This
+might seem a little complex but if your tests look like the simple
+examples in this doc then you don't need to worry as the depth will
+always be 1 and that's what Test::Tester expects by default.
+
+B<Note>: if you do not specify a value for depth in check_test() then it
+automatically compares it against 1, if you really want to skip the depth
+test then pass in undef.
+
+B<Note>: depth will not be correctly calculated for tests that run from a
+signal handler or an END block or anywhere else that hides the call stack.
+
+=back
+
+Some of Test::Tester's functions return arrays of these hashes, just
+like Test::Builder->details. That is, the hash for the first test will
+be array element 1 (not 0). Element 0 will not be a hash it will be a
+string which contains any diagnostic output that came before the first
+test. This should usually be empty, if it's not, it means something
+output diagnostics before any test results showed up.
+
+=head1 SPACES AND TABS
+
+Appearances can be deceptive, especially when it comes to emptiness. If you
+are scratching your head trying to work out why Test::Tester is saying that
+your diagnostics are wrong when they look perfectly right then the answer is
+probably whitespace. From version 0.10 on, Test::Tester surrounds the
+expected and got diag values with single quotes to make it easier to spot
+trailing whitesapce. So in this example
+
+ # Got diag (5 bytes):
+ # 'abcd '
+ # Expected diag (4 bytes):
+ # 'abcd'
+
+it is quite clear that there is a space at the end of the first string.
+Another way to solve this problem is to use colour and inverse video on an
+ANSI terminal, see below COLOUR below if you want this.
+
+Unfortunately this is sometimes not enough, neither colour nor quotes will
+help you with problems involving tabs, other non-printing characters and
+certain kinds of problems inherent in Unicode. To deal with this, you can
+switch Test::Tester into a mode whereby all "tricky" characters are shown as
+\{xx}. Tricky characters are those with ASCII code less than 33 or higher
+than 126. This makes the output more difficult to read but much easier to
+find subtle differences between strings. To turn on this mode either call
+show_space() in your test script or set the TESTTESTERSPACE environment
+variable to be a true value. The example above would then look like
+
+ # Got diag (5 bytes):
+ # abcd\x{20}
+ # Expected diag (4 bytes):
+ # abcd
+
+=head1 COLOUR
+
+If you prefer to use colour as a means of finding tricky whitespace
+characters then you can set the TESTTESTCOLOUR environment variable to a
+comma separated pair of colours, the first for the foreground, the second
+for the background. For example "white,red" will print white text on a red
+background. This requires the Term::ANSIColor module. You can specify any
+colour that would be acceptable to the Term::ANSIColor::color function.
+
+If you spell colour differently, that's no problem. The TESTTESTERCOLOR
+variable also works (if both are set then the British spelling wins out).
+
+=head1 EXPORTED FUNCTIONS
+
+=head3 ($premature, @results) = run_tests(\&test_sub)
+
+\&test_sub is a reference to a subroutine.
+
+run_tests runs the subroutine in $test_sub and captures the results of any
+tests inside it. You can run more than 1 test inside this subroutine if you
+like.
+
+$premature is a string containing any diagnostic output from before
+the first test.
+
+@results is an array of test result hashes.
+
+=head3 cmp_result(\%result, \%expect, $name)
+
+\%result is a ref to a test result hash.
+
+\%expect is a ref to a hash of expected values for the test result.
+
+cmp_result compares the result with the expected values. If any differences
+are found it outputs diagnostics. You may leave out any field from the
+expected result and cmp_result will not do the comparison of that field.
+
+=head3 cmp_results(\@results, \@expects, $name)
+
+\@results is a ref to an array of test results.
+
+\@expects is a ref to an array of hash refs.
+
+cmp_results checks that the results match the expected results and if any
+differences are found it outputs diagnostics. It first checks that the
+number of elements in \@results and \@expects is the same. Then it goes
+through each result checking it against the expected result as in
+cmp_result() above.
+
+=head3 ($premature, @results) = check_tests(\&test_sub, \@expects, $name)
+
+\&test_sub is a reference to a subroutine.
+
+\@expect is a ref to an array of hash refs which are expected test results.
+
+check_tests combines run_tests and cmp_tests into a single call. It also
+checks if the tests died at any stage.
+
+It returns the same values as run_tests, so you can further examine the test
+results if you need to.
+
+=head3 ($premature, @results) = check_test(\&test_sub, \%expect, $name)
+
+\&test_sub is a reference to a subroutine.
+
+\%expect is a ref to an hash of expected values for the test result.
+
+check_test is a wrapper around check_tests. It combines run_tests and
+cmp_tests into a single call, checking if the test died. It assumes
+that only a single test is run inside \&test_sub and include a test to
+make sure this is true.
+
+It returns the same values as run_tests, so you can further examine the test
+results if you need to.
+
+=head3 show_space()
+
+Turn on the escaping of characters as described in the SPACES AND TABS
+section.
+
+=head1 HOW IT WORKS
+
+Normally, a test module (let's call it Test:MyStyle) calls
+Test::Builder->new to get the Test::Builder object. Test::MyStyle calls
+methods on this object to record information about test results. When
+Test::Tester is loaded, it replaces Test::Builder's new() method with one
+which returns a Test::Tester::Delegate object. Most of the time this object
+behaves as the real Test::Builder object. Any methods that are called are
+delegated to the real Test::Builder object so everything works perfectly.
+However once we go into test mode, the method calls are no longer passed to
+the real Test::Builder object, instead they go to the Test::Tester::Capture
+object. This object seems exactly like the real Test::Builder object,
+except, instead of outputting test results and diagnostics, it just records
+all the information for later analysis.
+
+=head1 CAVEATS
+
+Support for calling Test::Builder->note is minimal. It's implemented
+as an empty stub, so modules that use it will not crash but the calls
+are not recorded for testing purposes like the others. Patches
+welcome.
+
+=head1 SEE ALSO
+
+L<Test::Builder> the source of testing goodness. L<Test::Builder::Tester>
+for an alternative approach to the problem tackled by Test::Tester -
+captures the strings output by Test::Builder. This means you cannot get
+separate access to the individual pieces of information and you must predict
+B<exactly> what your test will output.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::Tester::Capture;
+use strict;
+use warnings;
+
+use base 'Test::Builder';
+use Test::Stream qw/-internal STATE_LEGACY/;
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::create(@_);
+ $self->{stream}->set_use_tap(0);
+ $self->{stream}->set_use_legacy(1);
+ return $self;
+}
+
+sub details {
+ my $self = shift;
+
+ my $prem;
+ my @out;
+ for my $e (@{$self->{stream}->state->[-1]->[STATE_LEGACY]}) {
+ if ($e->isa('Test::Stream::Event::Ok')) {
+ push @out => $e->to_legacy;
+ $out[-1]->{diag} ||= "";
+ $out[-1]->{depth} = $e->level;
+ for my $d (@{$e->diag || []}) {
+ next if $d->message =~ m{Failed test .*\n\s*at .* line \d+\.};
+ chomp(my $msg = $d->message);
+ $msg .= "\n";
+ $out[-1]->{diag} .= $msg;
+ }
+ }
+ elsif ($e->isa('Test::Stream::Event::Diag')) {
+ chomp(my $msg = $e->message);
+ $msg .= "\n";
+ if (!@out) {
+ $prem .= $msg;
+ next;
+ }
+ next if $msg =~ m{Failed test .*\n\s*at .* line \d+\.};
+ $out[-1]->{diag} .= $msg;
+ }
+ }
+
+ return ($prem, @out) if $prem;
+ return @out;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Tester::Capture - Capture module for TesT::Tester
+
+=head1 DESCRIPTION
+
+Legacy support for Test::Tester.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+=pod
+
+=head1 NAME
+
+Test::Tutorial::WritingTests - A Complete Introduction to writing tests
+
+=head1 What are tests?
+
+Tests are code that verifies other code produces the expected output for a
+given input. An example may help:
+
+ # This code will die if math doesbn't work.
+ die "Math is broken" unless 1 + 1 == 2;
+
+However it is better to use a framework intended for testing:
+
+ ok( 1 + 1 == 2, "Math Works" );
+
+This will tell you if the test passes or fails, and will give you extra
+information like the name of the test, and what line it was written on if it
+fails.
+
+=head1 Simple example.
+
+ use Test::More;
+
+ ok( 1, "1 is true, this test will pass" );
+ ok( 0, "0 is false, this test will fail" );
+
+ is( 1 + 1, 2, "1 + 1 == 2" );
+
+ my @array = first_3_numbers();
+
+ is_deeply(
+ \@array,
+ [ 1, 2, 3 ],
+ "function returned an array of 3 numbers"
+ );
+
+ # When you are done, call this to satisfy the plan
+ done_testing
+
+See L<Test::More> for C<ok()>, C<is()>, C<is_deeply()>, and several other
+useful tools.
+
+=head1 What is a plan?
+
+You need to declare how many tests should be seen, this is to ensure your test
+does not die partway through. There are 2 ways to declare a plan, 1 way to
+decline to make a plan, and a way to skip everything.
+
+=over 4
+
+=item done_testing
+
+ use Test::More;
+
+ ok(1, "pass");
+
+ done_testing;
+
+Using done_testing means you do not need to update the plan every time you
+change your test script.
+
+=item Test count
+
+At import:
+
+ use Test::More tests => 1;
+ ok(1, "pass");
+
+Plan on its own:
+
+ use Test::More;
+ plan tests => 1;
+ ok(1, "pass");
+
+=item No Plan
+
+ use Test::More 'no_plan';
+
+No plan, no way to verify everything ran.
+
+=item skip_all
+
+ use Test::More skip_all => "We won't run these now";
+
+Just don't do anything.
+
+=back
+
+=head1 See Also
+
+L<Test::More>
+
+=head1 Writing tools.
+
+See L<Test::Tutorial::WritingTools>
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+=pod
+
+=head1 NAME
+
+Test::Tutorial::WritingTools - How to write testing tools.
+
+=head1 Examples
+
+=over 4
+
+=item Complete Example
+
+ package My::Tool;
+ use strict;
+ use warnings;
+
+ use Test::Stream::Toolset;
+ use Test::Stream::Exporter;
+
+ # Export 'validate_widget' by default.
+ default_exports qw/validate_widget/;
+
+ sub validate_widget {
+ my ($widget, $produces, $name) = @_;
+ my $ctx = context(); # Do this early as possible
+
+ my $value = $widget->produce;
+ my $ok = $value eq $produces;
+
+ if ($ok) {
+ # On success generate an ok event
+ $ctx->ok($ok, $name);
+ }
+ else {
+ # On failure generate an OK event with some diagnostics
+ $ctx->ok($ok, $name, ["Widget produced '$value'\n Wanted '$produces'"]);
+ }
+
+ # It is usually polite to return a true/false value.
+ return $ok ? 1 : 0;
+ }
+
+ 1;
+
+=item Alternate using Exporter.pm
+
+ package My::Tool;
+ use strict;
+ use warnings;
+
+ use Test::Stream::Toolset;
+
+ # Export 'validate_widget' by default.
+ use base 'Exporter';
+ our @EXPORT = qw/validate_widget/;
+
+ sub validate_widget {
+ my ($widget, $produces, $name) = @_;
+ my $ctx = context(); # Do this early as possible
+
+ my $value = $widget->produce;
+ my $ok = $value eq $produces;
+
+ if ($ok) {
+ # On success generate an ok event
+ $ctx->ok($ok, $name);
+ }
+ else {
+ # On failure generate an OK event with some diagnostics
+ $ctx->ok($ok, $name, ["Widget produced '$value'\n Wanted '$produces'"]);
+ }
+
+ # It is usually polite to return a true/false value.
+ return $ok ? 1 : 0;
+ }
+
+ 1;
+
+=back
+
+=head2 Explanation
+
+L<Test::Stream> is event based. Whenever you want to produce a result you will
+generate an event for it. The most common event is L<Test::Stream::Event::Ok>.
+Events require some extra information such as where and how they were produced.
+In general you do not need to worry about these extra details, they can be
+filled in by C<Test::Stream::Context>.
+
+To get a context object you call C<context()> which can be imported from
+L<Test::Stream::Context> itself, or from L<Test::Stream::Toolset>. Once you
+have a context object you can ask it to issue events for you. All event types
+C<Test::Stream::Event::*> get helper methods on the context object.
+
+=head2 IMPORTANT NOTE ON CONTEXTS
+
+The context object has some magic to it. Essentially it is a semi-singleton.
+That is if you generate a context object in one place, then try to generate
+another one in another place, you will just get the first one again so long as
+it still has a reference. If however the first one has fallen out of scope or
+been undefined, a new context is generated.
+
+The idea here is that if you nest functions that use contexts, all levels of
+depth will get the same initial context. On the other hand 2 functions run in
+sequence will get independant context objects. What this means is that you
+should NEVER store a context object in a package variable or object attribute.
+You should also never assign it to a variable in a higher scope.
+
+=head1 Nesting calls to other tools
+
+ use Test::More;
+ use Test::Stream::Toolset;
+
+ sub compound_check {
+ my ($object, $name) = @_;
+
+ # Grab the context now for nested tools to find
+ my $ctx = context;
+
+ my $ok = $object ? 1 : 0;
+ $ok &&= isa_ok($object, 'Some::Class');
+ $ok &&= can_ok($object, qw/foo bar baz/);
+ $ok &&= is($object->foo, 'my foo', $name);
+
+ $ctx->ok($ok, $name, $ok ? () : ['Not all object checks passed!']);
+
+ return $ok;
+ }
+
+ 1;
+
+Nesting tools just works as expected so long as you grab the context BEFORE you
+call them. Errors will be reported to the correct file and line number.
+
+=head1 Useful toolsets to look at
+
+=over 4
+
+=item L<Test::More::Tools>
+
+This is the collection of tools used by L<Test::More> under the hood. You can
+use these instead of L<Test::More> exports to duplicate functionality without
+generating extra events.
+
+=back
+
+=head1 Available Events
+
+Anyone can add an event by shoving it in the C<Test::Stream::Event::*>
+namespace. It will autoload if C<< $context->event_name >> is called. But here
+is the list of events that come with L<Test::Stream>.
+
+=over 4
+
+=item L<Test::Stream::Event::Ok>
+
+ $ctx->ok($bool, $name);
+ $ctx->ok($bool, $name, \@diag);
+
+Generate an Ok event.
+
+=item L<Test::Stream::Event::Diag>
+
+ $ctx->diag("Diag Message");
+
+Generate a diagniostics (stderr) message
+
+=item L<Test::Stream::Event::Note>
+
+ $ctx->note("Note Message");
+
+Generate a note (stdout) message
+
+=item L<Test::Stream::Event::Bail>
+
+ $ctx->bail("Reason we are bailing");
+
+Stop the entire test file, something is very wrong!
+
+=item L<Test::Stream::Event::Plan>
+
+ $ctx->plan($max);
+ $ctx->plan(0, $directive, $reason);
+
+Set the plan.
+
+=back
+
+=head1 Testing your tools
+
+See L<Test::Stream::Tester>, which lets you intercept and validate events.
+
+B<DO NOT SEE> C<Test::Tester> and C<Test::Builder::Tester> which are both
+deprecated. They were once the way everyone tested their testers, but they do
+not allow you to test all events, and they are very fragile when upstream libs
+change.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
--- /dev/null
+package Test::use::ok;
+use strict;
+use warnings;
+use 5.005;
+
+our $VERSION = '1.301001_075';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+use Test::Stream 1.301001 '-internal';
+
+1;
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+Test::use::ok - Alternative to Test::More::use_ok
+
+=head1 SYNOPSIS
+
+ use ok 'Some::Module';
+
+=head1 DESCRIPTION
+
+According to the B<Test::More> documentation, it used to be recommended to run
+C<use_ok()> inside a C<BEGIN> block, so functions are exported at compile-time
+and prototypes are properly honored.
+
+That is, instead of writing this:
+
+ use_ok( 'Some::Module' );
+ use_ok( 'Other::Module' );
+
+One should write this:
+
+ BEGIN { use_ok( 'Some::Module' ); }
+ BEGIN { use_ok( 'Other::Module' ); }
+
+However, people often either forget to add C<BEGIN>, or mistakenly group
+C<use_ok> with other tests in a single C<BEGIN> block, which can create subtle
+differences in execution order.
+
+With this module, simply change all C<use_ok> in test scripts to C<use ok>,
+and they will be executed at C<BEGIN> time. The explicit space after C<use>
+makes it clear that this is a single compile-time action.
+
+=head1 SEE ALSO
+
+L<Test::More>
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
+
+=cut
--- /dev/null
+package ok;
+use strict;
+use warnings;
+
+use Test::Stream 1.301001 '-internal';
+use Test::More 1.301001 ();
+use Test::Stream::Carp qw/croak/;
+
+our $VERSION = '1.301001_075';
+$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+sub import {
+ shift;
+
+ if (@_) {
+ croak "'use ok' called with an empty argument, did you try to use a package name from an uninitialized variable?"
+ unless defined $_[0];
+
+ goto &Test::More::pass if $_[0] eq 'ok';
+ goto &Test::More::use_ok;
+ }
+}
+
+1;
+
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+ok - Alternative to Test::More::use_ok
+
+=head1 SYNOPSIS
+
+ use ok 'Some::Module';
+
+=head1 DESCRIPTION
+
+With this module, simply change all C<use_ok> in test scripts to C<use ok>,
+and they will be executed at C<BEGIN> time.
+
+Please see L<Test::use::ok> for the full description.
+
+=encoding utf8
+
+=head1 SOURCE
+
+The source code repository for Test::More can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINER
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+The following people have all contributed to the Test-More dist (sorted using
+VIM's sort function).
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+
+=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+
+=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+
+=item 唐鳳
+
+=back
+
+=head1 COPYRIGHT
+
+There has been a lot of code migration between modules,
+here are all the original copyrights together:
+
+=over 4
+
+=item Test::Stream
+
+=item Test::Stream::Tester
+
+Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::Simple
+
+=item Test::More
+
+=item Test::Builder
+
+Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
+inspiration from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
+gang.
+
+Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+
+Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=item Test::use::ok
+
+To the extent possible under law, 唐鳳 has waived all copyright and related
+or neighboring rights to L<Test-use-ok>.
+
+This work is published from Taiwan.
+
+L<http://creativecommons.org/publicdomain/zero/1.0>
+
+=item Test::Tester
+
+This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
+are based on other people's work.
+
+Under the same license as Perl itself
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=item Test::Builder::Tester
+
+Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+=back
+++ /dev/null
-#!/usr/bin/perl -w
-
-# A test to make sure the new Test::Harness was installed properly.
-
-use Test::More;
-plan tests => 1;
-
-my $TH_Version = 2.03;
-
-require Test::Harness;
-unless( cmp_ok( eval $Test::Harness::VERSION, '>=', $TH_Version, "T::H version" ) ) {
- diag <<INSTRUCTIONS;
-
-Test::Simple/More/Builder has features which depend on a version of
-Test::Harness greater than $TH_Version. You have $Test::Harness::VERSION.
-Please install a new version from CPAN.
-
-If you've already tried to upgrade Test::Harness and still get this
-message, the new version may be "shadowed" by the old. Check the
-output of Test::Harness's "make install" for "## Differing version"
-messages. You can delete the old version by running
-"make install UNINST=1".
-
-INSTRUCTIONS
-}
-
--- /dev/null
+use Test::More;
+ok(1,"name");
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Config;
+
+BEGIN {
+ if ($] == 5.010000) {
+ print "1..0 # Threads are broken on 5.10.0\n";
+ exit 0;
+ }
+
+ my $works = 1;
+ $works &&= $] >= 5.008001;
+ $works &&= $Config{'useithreads'};
+ $works &&= eval { require threads; 'threads'->import; 1 };
+
+ unless ($works) {
+ print "1..0 # Skip no working threads\n";
+ exit 0;
+ }
+
+ unless ( $ENV{AUTHOR_TESTING} ) {
+ print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n";
+ exit 0;
+ }
+}
+
+use threads;
+use Test::More;
+
+subtest my_subtest => sub {
+ my $file = __FILE__;
+ $file =~ s/\.t$/.load/;
+ do $file || die $@;
+};
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+use Test::Stream::Tester;
+
+my $want = 0;
+my $got = 0;
+
+cmp_ok($got, 'eq', $want, "Passes on correct comparison");
+
+my @warn;
+my $events = intercept {
+ no warnings 'redefine';
+ local $SIG{__WARN__} = sub {
+ push @warn => @_;
+ };
+ cmp_ok($got, '#eq', $want, "You shall not pass!");
+};
+
+# We are not going to inspect the warning because it is not super predictable,
+# and changes with eval specifics.
+ok(@warn, "We got warnings");
+
+events_are(
+ $events,
+ check {
+ event ok => {
+ bool => 0,
+ diag => qr/syntax error at \(eval in cmp_ok\)/,
+ };
+ },
+ "Events meet expectations"
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+
+BEGIN {
+ $INC{'My/Tester.pm'} = __FILE__;
+ package My::Tester;
+ use Test::More;
+ use base 'Test::More';
+
+ our @EXPORT = (@Test::More::EXPORT, qw/foo/);
+ our @EXPORT_OK = (@Test::More::EXPORT_OK);
+
+ sub foo { goto &Test::More::ok }
+
+ 1;
+}
+
+use My::Tester;
+
+can_ok(__PACKAGE__, qw/ok done_testing foo/);
+
+foo(1, "This is just an ok");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use B;
+
+use Test::Stream;
+use Test::MostlyLike;
+use Test::More tests => 3;
+use Test::Builder; # Not loaded by default in modern mode
+my $orig = Test::Builder->can('diag');
+
+{
+ package MyModernTester;
+ use Test::More;
+ use Test::Stream;
+ use Test::MostlyLike;
+
+ no warnings 'redefine';
+ local *Test::Builder::diag = sub {
+ my $self = shift;
+ return $self->$orig(__PACKAGE__ . ": ", @_);
+ };
+ use warnings;
+
+ my $file = __FILE__;
+ # Line number is tricky, just use what B says The sub may not actually think it
+ # is on the line it is may be off by 1.
+ my $line = B::svref_2object(\&Test::Builder::diag)->START->line;
+
+ my @warnings;
+ {
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ diag('first');
+ diag('seconds');
+ }
+ mostly_like(
+ \@warnings,
+ [
+ qr{The new sub is 'MyModernTester::__ANON__' defined in \Q$file\E around line $line},
+ undef, #Only 1 warning
+ ],
+ "Found expected warning, just the one"
+ );
+}
+
+{
+ package MyModernTester2;
+ use Test::More;
+ use Test::Stream;
+ use Test::MostlyLike;
+
+ no warnings 'redefine';
+ local *Test::Builder::diag = sub {
+ my $self = shift;
+ return $self->$orig(__PACKAGE__ . ": ", @_);
+ };
+ use warnings;
+
+ my $file = __FILE__;
+ # Line number is tricky, just use what B says The sub may not actually think it
+ # is on the line it is may be off by 1.
+ my $line = B::svref_2object(\&Test::Builder::diag)->START->line;
+
+ my @warnings;
+ {
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ diag('first');
+ diag('seconds');
+ }
+ mostly_like(
+ \@warnings,
+ [
+ qr{The new sub is 'MyModernTester2::__ANON__' defined in \Q$file\E around line $line},
+ undef, #Only 1 warning
+ ],
+ "new override, new warning"
+ );
+}
+
+{
+ package MyLegacyTester;
+ use Test::More;
+
+ no warnings 'redefine';
+ local *Test::Builder::diag = sub {
+ my $self = shift;
+ return $self->$orig(__PACKAGE__ . ": ", @_);
+ };
+ use warnings;
+
+ my @warnings;
+ {
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ diag('first');
+ diag('seconds');
+ }
+ is(@warnings, 0, "no warnings for a legacy tester");
+}
--- /dev/null
+use strict;
+use warnings;
+use B;
+
+use Test::Stream;
+use Test::MostlyLike;
+use Test::More tests => 4;
+use Test::Builder; # Not loaded by default in modern mode
+my $orig = Test::Builder->can('done_testing');
+
+use Test::Stream::Tester;
+
+my $ran = 0;
+no warnings 'redefine';
+my $file = __FILE__;
+my $line = __LINE__ + 1;
+*Test::Builder::done_testing = sub { my $self = shift; $ran++; $self->$orig(@_) };
+use warnings;
+
+my @warnings;
+$SIG{__WARN__} = sub { push @warnings => @_ };
+
+events_are(
+ intercept {
+ ok(1, "pass");
+ ok(0, "fail");
+
+ done_testing;
+ },
+ check {
+ event ok => { bool => 1 };
+ event ok => { bool => 0 };
+ event plan => { max => 2 };
+ directive 'end';
+ },
+);
+
+events_are(
+ intercept {
+ ok(1, "pass");
+ ok(0, "fail");
+
+ done_testing;
+ },
+ check {
+ event ok => { bool => 1 };
+ event ok => { bool => 0 };
+ event plan => { max => 2 };
+ directive 'end';
+ },
+);
+
+is($ran, 2, "We ran our override both times");
+mostly_like(
+ \@warnings,
+ [
+ qr{The new sub is 'main::__ANON__' defined in \Q$file\E around line $line},
+ undef,
+ ],
+ "Got the warning once"
+);
--- /dev/null
+use strict;
+use warnings;
+use B;
+
+use Test::Stream;
+use Test::MostlyLike;
+use Test::More tests => 3;
+use Test::Builder; # Not loaded by default in modern mode
+my $orig = Test::Builder->can('note');
+
+{
+ package MyModernTester;
+ use Test::More;
+ use Test::Stream;
+ use Test::MostlyLike;
+
+ no warnings 'redefine';
+ local *Test::Builder::note = sub {
+ my $self = shift;
+ return $self->$orig(__PACKAGE__ . ": ", @_);
+ };
+ use warnings;
+
+ my $file = __FILE__;
+ # Line number is tricky, just use what B says The sub may not actually think it
+ # is on the line it is may be off by 1.
+ my $line = B::svref_2object(\&Test::Builder::note)->START->line;
+
+ my @warnings;
+ {
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ note('first');
+ note('seconds');
+ }
+ mostly_like(
+ \@warnings,
+ [
+ qr{The new sub is 'MyModernTester::__ANON__' defined in \Q$file\E around line $line},
+ undef, #Only 1 warning
+ ],
+ "Found expected warning, just the one"
+ );
+}
+
+{
+ package MyModernTester2;
+ use Test::More;
+ use Test::Stream;
+ use Test::MostlyLike;
+
+ no warnings 'redefine';
+ local *Test::Builder::note = sub {
+ my $self = shift;
+ return $self->$orig(__PACKAGE__ . ": ", @_);
+ };
+ use warnings;
+
+ my $file = __FILE__;
+ # Line number is tricky, just use what B says The sub may not actually think it
+ # is on the line it is may be off by 1.
+ my $line = B::svref_2object(\&Test::Builder::note)->START->line;
+
+ my @warnings;
+ {
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ note('first');
+ note('seconds');
+ }
+ mostly_like(
+ \@warnings,
+ [
+ qr{The new sub is 'MyModernTester2::__ANON__' defined in \Q$file\E around line $line},
+ undef, #Only 1 warning
+ ],
+ "new override, new warning"
+ );
+}
+
+{
+ package MyLegacyTester;
+ use Test::More;
+
+ no warnings 'redefine';
+ local *Test::Builder::note = sub {
+ my $self = shift;
+ return $self->$orig(__PACKAGE__ . ": ", @_);
+ };
+ use warnings;
+
+ my @warnings;
+ {
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ note('first');
+ note('seconds');
+ }
+ is(@warnings, 0, "no warnings for a legacy tester");
+}
--- /dev/null
+use strict;
+use warnings;
+use B;
+
+use Test::Stream;
+use Test::MostlyLike;
+use Test::More tests => 9;
+use Test::Builder; # Not loaded by default in modern mode
+my $orig = Test::Builder->can('ok');
+
+{
+ package MyModernTester;
+ use Test::Stream;
+ use Test::MostlyLike;
+ use Test::More;
+
+ no warnings 'redefine';
+ local *Test::Builder::ok = sub {
+ my $self = shift;
+ my ($bool, $name) = @_;
+ $name = __PACKAGE__ . ": $name";
+ return $self->$orig($bool, $name);
+ };
+ use warnings;
+
+ my $file = __FILE__;
+ # Line number is tricky, just use what B says The sub may not actually think it
+ # is on the line it is may be off by 1.
+ my $line = B::svref_2object(\&Test::Builder::ok)->START->line;
+
+ my @warnings;
+ {
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ ok(1, "fred");
+ ok(2, "barney");
+ }
+ mostly_like(
+ \@warnings,
+ [
+ qr{The new sub is 'MyModernTester::__ANON__' defined in \Q$file\E around line $line},
+ undef, #Only 1 warning
+ ],
+ "Found expected warning, just the one"
+ );
+}
+
+{
+ package MyModernTester2;
+ use Test::Stream;
+ use Test::MostlyLike;
+ use Test::More;
+
+ no warnings 'redefine';
+ local *Test::Builder::ok = sub {
+ my $self = shift;
+ my ($bool, $name) = @_;
+ $name = __PACKAGE__ . ": $name";
+ return $self->$orig($bool, $name);
+ };
+ use warnings;
+
+ my $file = __FILE__;
+ # Line number is tricky, just use what B says The sub may not actually think it
+ # is on the line it is may be off by 1.
+ my $line = B::svref_2object(\&Test::Builder::ok)->START->line;
+
+ my @warnings;
+ {
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ ok(1, "fred");
+ ok(2, "barney");
+ }
+ mostly_like(
+ \@warnings,
+ [
+ qr{The new sub is 'MyModernTester2::__ANON__' defined in \Q$file\E around line $line},
+ undef, #Only 1 warning
+ ],
+ "new override, new warning"
+ );
+}
+
+{
+ package MyLegacyTester;
+ use Test::More;
+
+ no warnings 'redefine';
+ local *Test::Builder::ok = sub {
+ my $self = shift;
+ my ($bool, $name) = @_;
+ $name = __PACKAGE__ . ": $name";
+ return $self->$orig($bool, $name);
+ };
+ use warnings;
+
+ my $file = __FILE__;
+ # Line number is tricky, just use what B says The sub may not actually think it
+ # is on the line it is may be off by 1.
+ my $line = B::svref_2object(\&Test::Builder::ok)->START->line;
+
+ my @warnings;
+ {
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ ok(1, "fred");
+ ok(2, "barney");
+ }
+ is(@warnings, 0, "no warnings for a legacy tester");
+}
--- /dev/null
+use strict;
+use warnings;
+use B;
+
+use Test::Stream;
+use Test::MostlyLike;
+use Test::More tests => 6;
+use Test::Builder; # Not loaded by default in modern mode
+my $orig = Test::Builder->can('plan');
+
+use Test::Stream::Tester;
+
+my $ran = 0;
+no warnings 'redefine';
+my $file = __FILE__;
+my $line = __LINE__ + 1;
+*Test::Builder::plan = sub { my $self = shift; $ran++; $self->$orig(@_) };
+use warnings;
+
+my @warnings;
+$SIG{__WARN__} = sub { push @warnings => @_ };
+
+events_are(
+ intercept {
+ plan tests => 2;
+ ok(1, "pass");
+ ok(0, "fail");
+ },
+ check {
+ event plan => { max => 2 };
+ event ok => { bool => 1 };
+ event ok => { bool => 0 };
+ directive 'end';
+ },
+);
+
+events_are(
+ intercept {
+ Test::More->import('tests' => 2);
+ ok(1, "pass");
+ ok(0, "fail");
+ },
+ check {
+ event plan => { max => 2 };
+ event ok => { bool => 1 };
+ event ok => { bool => 0 };
+ directive 'end';
+ },
+);
+
+events_are(
+ intercept {
+ Test::More->import(skip_all => 'damn');
+ ok(1, "pass");
+ ok(0, "fail");
+ },
+ check {
+ event plan => { max => 0, directive => 'SKIP', reason => 'damn' };
+ directive 'end';
+ },
+);
+
+events_are(
+ intercept {
+ Test::More->import('no_plan');
+ ok(1, "pass");
+ ok(0, "fail");
+ },
+ check {
+ event plan => { directive => 'NO PLAN' };
+ event ok => { bool => 1 };
+ event ok => { bool => 0 };
+ directive 'end';
+ },
+);
+
+is($ran, 4, "We ran our override each time");
+mostly_like(
+ \@warnings,
+ [
+ qr{The new sub is 'main::__ANON__' defined in \Q$file\E around line $line},
+ undef,
+ ],
+ "Got the warning once"
+);
+
--- /dev/null
+use strict;
+use warnings;
+use Test::Stream;
+use Test::More;
+use Test::Stream::Tester;
+
+events_are(
+ intercept {
+ my $id = 0;
+ Test::Stream->shared->munge(sub {
+ my ($stream, $e) = @_;
+ return unless $e->isa('Test::Stream::Event::Ok');
+ return if defined $e->name;
+ $e->set_name( 'flubber: ' . $id++ );
+ });
+
+ ok( 1, "Keep the name" );
+ ok( 1 );
+ ok( 1, "Already named" );
+ ok( 1 );
+ },
+ check {
+ event ok => { bool => 1, name => "Keep the name" };
+ event ok => { bool => 1, name => "flubber: 0" };
+ event ok => { bool => 1, name => "Already named" };
+ event ok => { bool => 1, name => "flubber: 1" };
+ }
+);
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Builder;
+
+# This is just a list of method Test::Builder current does not have that Test::Builder 1.5 does.
+my @TB15_METHODS = qw{
+ _file_and_line _join_message _make_default _my_exit _reset_todo_state
+ _result_to_hash _results _todo_state formatter history in_test
+ no_change_exit_code post_event post_result set_formatter set_plan test_end
+ test_exit_code test_start test_state
+};
+
+for my $method (qw/foo bar baz/) {
+ my $success = !eval { Test::Builder->$method; 1 }; my $line = __LINE__;
+ my $error = $@;
+ ok($success, "Threw an exception ($method)");
+ is(
+ $error,
+ qq{Can't locate object method "$method" via package "Test::Builder" at } . __FILE__ . " line $line.\n",
+ "Did not auto-create random sub ($method)"
+ );
+}
+
+my $file = __FILE__;
+for my $method (@TB15_METHODS) {
+ my $success = !eval { Test::Builder->$method; 1 }; my $line = __LINE__;
+ my $error = $@;
+
+ ok($success, "Threw an exception ($method)");
+
+ is($error, <<" EOT", "Got expected error ($method)");
+Can't locate object method "$method" via package "Test::Builder" at $file line $line.
+
+ *************************************************************************
+ '$method' is a Test::Builder 1.5 method. Test::Builder 1.5 is a dead branch.
+ You need to update your code so that it no longer treats Test::Builders
+ over a specific version number as anything special.
+
+ See: http://blogs.perl.org/users/chad_exodist_granum/2014/03/testmore---new-maintainer-also-stop-version-checking.html
+ *************************************************************************
+ EOT
+}
+
+done_testing;
+
--- /dev/null
+use strict;
+use warnings;
+use utf8;
+
+use Test::Stream;
+use Test::More;
+use Test::Stream::Tester;
+
+my $events = intercept {
+ ok(0, "test failure" );
+ ok(1, "test success" );
+
+ subtest 'subtest' => sub {
+ ok(0, "subtest failure" );
+ ok(1, "subtest success" );
+
+ subtest 'subtest_deeper' => sub {
+ ok(1, "deeper subtest success" );
+ };
+ };
+
+ ok(0, "another test failure" );
+ ok(1, "another test success" );
+};
+
+events_are(
+ $events,
+
+ check {
+ event ok => {bool => 0, diag => qr/Fail/};
+ event ok => {bool => 1};
+
+ event note => {message => 'Subtest: subtest'};
+ event subtest => {
+ name => 'subtest',
+ bool => 0,
+ diag => qr/Failed test 'subtest'/,
+
+ events => check {
+ event ok => {bool => 0};
+ event ok => {bool => 1};
+
+ event note => {message => 'Subtest: subtest_deeper'};
+ event subtest => {
+ bool => 1,
+ name => 'subtest_deeper',
+ events => check {
+ event ok => { bool => 1 };
+ },
+ };
+
+ event plan => { max => 3 };
+ event finish => { tests_run => 3, tests_failed => 1 };
+ event diag => { message => qr/Looks like you failed 1 test of 3/ };
+
+ dir end => 'End of subtests events';
+ },
+ };
+
+ event ok => {bool => 0};
+ event ok => {bool => 1};
+
+ dir end => "subtest events as expected";
+ },
+
+ "Subtest events"
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Stream;
+use Test::More;
+
+my @warnings;
+$SIG{__WARN__} = sub { push @warnings => @_ };
+my $ok = cmp_ok( 1, 'xor', 0, 'use xor in cmp_ok' );
+ok(!@warnings, "no warnings");
+ok($ok, "returned true");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+no utf8;
+
+# line 5 "encoding_tést.t"
+
+use Test::Stream;
+use Test::More;
+use Test::Stream::Tester;
+
+BEGIN {
+ my $norm = eval { require Unicode::Normalize; require Encode; 1 };
+ plan skip_all => 'Unicode::Normalize is required for this test' unless $norm;
+}
+
+my $filename = __FILE__;
+ok(!utf8::is_utf8($filename), "filename is not in utf8 yet");
+my $utf8name = Unicode::Normalize::NFKC(Encode::decode('utf8', "$filename", Encode::FB_CROAK));
+ok( $filename ne $utf8name, "sanity check" );
+
+my $scoper = sub { context()->snapshot };
+
+tap_encoding 'utf8';
+my $ctx_utf8 = $scoper->();
+
+tap_encoding 'legacy';
+my $ctx_legacy = $scoper->();
+
+is($ctx_utf8->encoding, 'utf8', "got a utf8 context");
+is($ctx_legacy->encoding, 'legacy', "got a legacy context");
+
+is($ctx_utf8->file, $utf8name, "Got utf8 name");
+is($ctx_legacy->file, $filename, "Got legacy name");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if ($] == 5.010000) {
+ print "1..0 # Threads are broken on 5.10.0\n";
+ exit 0;
+ }
+
+ my $works = 1;
+ $works &&= $] >= 5.008001;
+ $works &&= $Config{'useithreads'};
+ $works &&= eval { require threads; 'threads'->import; 1 };
+
+ unless ($works) {
+ print "1..0 # Skip no working threads\n";
+ exit 0;
+ }
+
+ unless ( $ENV{AUTHOR_TESTING} ) {
+ print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n";
+ exit 0;
+ }
+}
+
+use Test::More tests => 4;
+
+ok(1, "outside before");
+
+my $run = sub {
+ ok(1, 'in thread1');
+ ok(1, 'in thread2');
+};
+
+
+my $t = threads->create($run);
+
+ok(1, "outside after");
+
+$t->join;
+
+END {
+ print "XXX: " . Test::Builder->new->is_passing . "\n";
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Carp qw/confess/;
+
+use Test::More skip_all => "Cause I feel like it";
+
+confess "Should not see this!";
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+subtest my_subtest => sub {
+ my $file = __FILE__;
+ $file =~ s/\.t$/.load/;
+ do $file;
+ note "Got: $@";
+ fail($@);
+};
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl -w -T
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if ($] == 5.010000) {
+ print "1..0 # Threads are broken on 5.10.0\n";
+ exit 0;
+ }
+
+ my $works = 1;
+ $works &&= $] >= 5.008001;
+ $works &&= $Config{'useithreads'};
+ $works &&= eval { require threads; 'threads'->import; 1 };
+
+ unless ($works) {
+ print "1..0 # Skip no working threads\n";
+ exit 0;
+ }
+
+ unless ( $ENV{AUTHOR_TESTING} ) {
+ print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n";
+ exit 0;
+ }
+}
+
+use strict;
+use Test::Builder;
+
+my $Test = Test::Builder->new;
+$Test->exported_to('main');
+$Test->plan(tests => 6);
+
+for(1..5) {
+ 'threads'->create(sub {
+ $Test->ok(1,"Each of these should app the test number")
+ })->join;
+}
+
+$Test->is_num($Test->current_test(), 5,"Should be five");
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Stream::Tester;
+
+my $events = intercept {
+ local $TODO = "";
+ ok(0, "Should not be in todo 1");
+
+ local $TODO = 0;
+ ok(0, "Should not be in todo 2");
+
+ local $TODO = undef;
+ ok(0, "Should not be in todo 3");
+
+ local $TODO = "foo";
+ ok(0, "Should be in todo");
+};
+
+events_are(
+ $events,
+ check {
+ event ok => { in_todo => 0 };
+ event ok => { in_todo => 0 };
+ event ok => { in_todo => 0 };
+ event ok => { in_todo => 1 };
+ directive 'end';
+ },
+ "Verify TODO state"
+);
+
+my $i = 0;
+for my $e (@$events) {
+ next if $e->context->in_todo;
+
+ my @tap = $e->to_tap(++$i);
+ my $ok_line = $tap[0];
+ chomp(my $text = $ok_line->[1]);
+ is($text, "not ok $i - Should not be in todo $i", "No TODO directive $i");
+}
+
+done_testing;
+++ /dev/null
-#!perl -w
-use strict;
-use warnings;
-use IO::Pipe;
-use Test::Builder;
-use Config;
-
-my $b = Test::Builder->new;
-$b->reset;
-
-my $Can_Fork = $Config{d_fork} ||
- (($^O eq 'MSWin32' || $^O eq 'NetWare') and
- $Config{useithreads} and
- $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
- );
-
-if( !$Can_Fork ) {
- $b->plan('skip_all' => "This system cannot fork");
-}
-else {
- $b->plan('tests' => 2);
-}
-
-my $pipe = IO::Pipe->new;
-if ( my $pid = fork ) {
- $pipe->reader;
- $b->ok((<$pipe> =~ /FROM CHILD: ok 1/), "ok 1 from child");
- $b->ok((<$pipe> =~ /FROM CHILD: 1\.\.1/), "1..1 from child");
- waitpid($pid, 0);
-}
-else {
- $pipe->writer;
- my $pipe_fd = $pipe->fileno;
- close STDOUT;
- open(STDOUT, ">&$pipe_fd");
- my $b = Test::Builder->new;
- $b->reset;
- $b->no_plan;
- $b->ok(1);
-}
-
-
-=pod
-#actual
-1..2
-ok 1
-1..1
-ok 1
-ok 2
-#expected
-1..2
-ok 1
-ok 2
-=cut
+++ /dev/null
-#!perl -w
-
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = ('../lib', 'lib');
- }
- else {
- unshift @INC, 't/lib';
- }
-}
-
-use strict;
-
-use Test::More 'no_plan';
-
-require Test::Builder;
-my $tb = Test::Builder->new;
-
-
-# Test that _try() has no effect on $@ and $! and is not effected by
-# __DIE__
-{
- local $SIG{__DIE__} = sub { fail("DIE handler called: @_") };
- local $@ = 42;
- local $! = 23;
-
- is $tb->_try(sub { 2 }), 2;
- is $tb->_try(sub { return '' }), '';
-
- is $tb->_try(sub { die; }), undef;
-
- is_deeply [$tb->_try(sub { die "Foo\n" })], [undef, "Foo\n"];
-
- is $@, 42;
- cmp_ok $!, '==', 23;
-}
-
-ok !eval {
- $tb->_try(sub { die "Died\n" }, die_on_fail => 1);
-};
-is $@, "Died\n";
#!/usr/bin/perl
+use strict;
+use warnings;
BEGIN {
if( $ENV{PERL_CORE} ) {
use Test::More tests => 3;
use Test::Builder;
+use Test::Stream::Context qw/context/;
-my $tb = Test::Builder->create;
-sub foo { $tb->croak("foo") }
-sub bar { $tb->carp("bar") }
+sub foo { my $ctx = context(); Test::Builder->new->croak("foo") }
+sub bar { my $ctx = context(); Test::Builder->new->carp("bar") }
eval { foo() };
is $@, sprintf "foo at %s line %s.\n", $0, __LINE__ - 1;
-eval { $tb->croak("this") };
+eval { Test::Builder->new->croak("this") };
is $@, sprintf "this at %s line %s.\n", $0, __LINE__ - 1;
{
use Test::Builder;
my $tb = Test::Builder->new;
-$tb->plan( tests => 2 );
+$tb->plan(tests => 2);
$tb->ok(1);
$tb->ok(1);
$tb->done_testing(2);
--- /dev/null
+#!perl -w
+use strict;
+use warnings;
+use IO::Pipe;
+use Test::Builder;
+use Config;
+
+my $b = Test::Builder->new;
+$b->reset;
+
+my $Can_Fork = $Config{d_fork}
+ || (($^O eq 'MSWin32' || $^O eq 'NetWare')
+ and $Config{useithreads}
+ and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/);
+
+if (!$Can_Fork) {
+ $b->plan('skip_all' => "This system cannot fork");
+}
+elsif ($^O eq 'MSWin32' && $] == 5.010000) {
+ $b->plan('skip_all' => "5.10 has fork/threading issues that break fork on win32");
+}
+else {
+ $b->plan('tests' => 2);
+}
+
+my $pipe = IO::Pipe->new;
+if (my $pid = fork) {
+ $pipe->reader;
+ my @output = <$pipe>;
+ $b->like($output[0], qr/ok 1/, "ok 1 from child");
+ $b->like($output[1], qr/1\.\.1/, "got 1..1 from child");
+ waitpid($pid, 0);
+}
+else {
+ Test::Stream::IOSets->hard_reset;
+ Test::Stream->clear;
+ $pipe->writer;
+ my $pipe_fd = $pipe->fileno;
+ close STDOUT;
+ open(STDOUT, ">&$pipe_fd");
+ my $b = Test::Builder->create(shared_stream => 1);
+ $b->reset;
+ $b->no_plan;
+ $b->ok(1);
+
+ exit 0;
+}
+
+=pod
+#actual
+1..2
+ok 1
+1..1
+ok 1
+ok 2
+#expected
+1..2
+ok 1
+ok 2
+=cut
sub isa {
my $self = shift;
my $parent = shift;
-
+
return 1 if $parent eq 'IO::Handle';
}
SKIP: {
skip "blessed regex checker added in 5.10", 3 if $] < 5.010;
-
+
my $obj = bless qr/foo/, 'Wibble';
my $re = $Test->maybe_regex($obj);
ok( defined $re, "blessed regex detected" );
}
chdir 't';
-
use Test::Builder;
my $Test = Test::Builder->new;
my $tb = Test::Builder->create;
$Test->is_eq( $tb->level, 1, 'level' );
$Test->is_eq( $tb->use_numbers, 1, 'use_numbers' );
$Test->is_eq( $tb->no_header, 0, 'no_header' );
-$Test->is_eq( $tb->no_ending, 0, 'no_ending' );
$Test->is_eq( $tb->current_test, 0, 'current_test' );
$Test->is_eq( scalar $tb->summary, 0, 'summary' );
$Test->is_eq( scalar $tb->details, 0, 'details' );
# The reset Test::Builder will take over from here.
$Test->no_ending(1);
-
$tb->current_test($Test->current_test);
$tb->level(0);
$tb->ok(1, 'final test to make sure output was reset');
--- /dev/null
+#!perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use Test::Builder;
+use Test::More 'no_plan';
+
+{
+ my $tb = Test::Builder->create();
+
+ # Store the original output filehandles and change them all.
+ my %original_outputs;
+
+ open my $fh, ">", "dummy_file.tmp";
+ END { 1 while unlink "dummy_file.tmp"; }
+ for my $method (qw(output failure_output todo_output)) {
+ $original_outputs{$method} = $tb->$method();
+ $tb->$method($fh);
+ is $tb->$method(), $fh;
+ }
+
+ $tb->reset_outputs;
+
+ for my $method (qw(output failure_output todo_output)) {
+ is $tb->$method(), $original_outputs{$method}, "reset_outputs() resets $method";
+ }
+}
use lib 't/lib';
use Test::More tests => 54;
+use Test::Builder;
# Make sure we don't mess with $@ or $!. Test at bottom.
my $Err = "this should not be touched";
can_ok('Test::More', qw(require_ok use_ok ok is isnt like skip can_ok
pass fail eq_array eq_hash eq_set));
-can_ok(bless({}, "Test::More"), qw(require_ok use_ok ok is isnt like skip
+can_ok(bless({}, "Test::More"), qw(require_ok use_ok ok is isnt like skip
can_ok pass fail eq_array eq_hash eq_set));
}
-# can_ok() & isa_ok should call can() & isa() on the given object, not
+# can_ok() & isa_ok should call can() & isa() on the given object, not
# just class, in case of custom can()
{
local *Foo::can;
'eq_hash with slightly different complicated hashes' );
is @Test::More::Data_Stack, 0;
-is( Test::Builder->new, Test::More->builder, 'builder()' );
+is( Test::Builder->new, Test::More->builder, 'builder()' );
cmp_ok(42, '==', 42, 'cmp_ok ==');
--- /dev/null
+use Test::More;
+require PerlIO;
+
+my $ok = 1;
+my %counts;
+for my $layer (PerlIO::get_layers(Test::Stream->shared->io_sets->{legacy}->[0])) {
+ my $dup = $counts{$layer}++;
+ ok(!$dup, "No IO layer duplication '$layer'");
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use Test::Tester tests => 4;
+
+use SmallTest;
+
+use MyTest;
+
+{
+ my ($prem, @results) = run_tests(sub { MyTest::ok(1, "run pass") });
+
+ is_eq($results[0]->{name}, "run pass");
+ is_num($results[0]->{ok}, 1);
+}
+
+{
+ my ($prem, @results) = run_tests(sub { MyTest::ok(0, "run fail") });
+
+ is_eq($results[0]->{name}, "run fail");
+ is_num($results[0]->{ok}, 0);
+}
--- /dev/null
+use strict;
+
+use Test::Tester;
+
+use Data::Dumper qw(Dumper);
+
+my $test = Test::Builder->new;
+$test->plan(tests => 105);
+
+my $cap;
+
+$cap = $test;
+
+my @tests = (
+ [
+ 'pass',
+ '$cap->ok(1, "pass");',
+ {
+ name => "pass",
+ ok => 1,
+ actual_ok => 1,
+ reason => "",
+ type => "",
+ diag => "",
+ depth => 0,
+ },
+ ],
+ [
+ 'pass diag',
+ '$cap->ok(1, "pass diag");
+ $cap->diag("pass diag1");
+ $cap->diag("pass diag2");',
+ {
+ name => "pass diag",
+ ok => 1,
+ actual_ok => 1,
+ reason => "",
+ type => "",
+ diag => "pass diag1\npass diag2\n",
+ depth => 0,
+ },
+ ],
+ [
+ 'pass diag no \\n',
+ '$cap->ok(1, "pass diag");
+ $cap->diag("pass diag1");
+ $cap->diag("pass diag2");',
+ {
+ name => "pass diag",
+ ok => 1,
+ actual_ok => 1,
+ reason => "",
+ type => "",
+ diag => "pass diag1\npass diag2",
+ depth => 0,
+ },
+ ],
+ [
+ 'fail',
+ '$cap->ok(0, "fail");
+ $cap->diag("fail diag");',
+ {
+ name => "fail",
+ ok => 0,
+ actual_ok => 0,
+ reason => "",
+ type => "",
+ diag => "fail diag\n",
+ depth => 0,
+ },
+ ],
+ [
+ 'skip',
+ '$cap->skip("just because");',
+ {
+ name => "",
+ ok => 1,
+ actual_ok => 1,
+ reason => "just because",
+ type => "skip",
+ diag => "",
+ depth => 0,
+ },
+ ],
+ [
+ 'todo_skip',
+ '$cap->todo_skip("why not");',
+ {
+ name => "",
+ ok => 1,
+ actual_ok => 0,
+ reason => "why not",
+ type => "todo_skip",
+ diag => "",
+ depth => 0,
+ },
+ ],
+);
+
+my $big_code = "";
+my @big_expect;
+
+foreach my $test (@tests) {
+ my ($name, $code, $expect) = @$test;
+
+ $big_code .= "$code\n";
+ push(@big_expect, $expect);
+
+ my $test_sub = eval "sub {$code}";
+
+ check_test($test_sub, $expect, $name);
+}
+
+my $big_test_sub = eval "sub {$big_code}";
+
+check_tests($big_test_sub, \@big_expect, "run all");
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+
+use Test::Tester;
+
+use MyTest;
+
+my $test = Test::Builder->new;
+$test->plan(tests => 2);
+
+sub deeper
+{
+ MyTest::ok(1);
+}
+
+{
+
+ my @results = run_tests(
+ sub {
+ MyTest::ok(1);
+ deeper();
+ }
+ );
+
+ local $Test::Builder::Level = 0;
+ $test->is_num($results[1]->{depth}, 1, "depth 1");
+ $test->is_num($results[2]->{depth}, 2, "deeper");
+}
+
--- /dev/null
+use strict;
+use warnings;
+use Test::Tester;
+use Test::More;
+
+check_test(
+ sub { is "Foo", "Foo" },
+ {ok => 1},
+);
+
+check_test(
+ sub { is "Bar", "Bar" },
+ {ok => 1},
+);
+
+check_test(
+ sub { is "Baz", "Quux" },
+ {ok => 0},
+);
+
+check_test(
+ sub { like "Baz", qr/uhg/ },
+ {ok => 0},
+);
+
+check_test(
+ sub { like "Baz", qr/a/ },
+ {ok => 1},
+);
+
+done_testing();
--- /dev/null
+use strict;
+
+use Test::Tester;
+
+use Data::Dumper qw(Dumper);
+
+my $test = Test::Builder->new;
+$test->plan(tests => 54);
+
+my $cap;
+
+{
+ $cap = $test;
+ my ($prem, @results) = run_tests(
+ sub {$cap->ok(1, "run pass")}
+ );
+
+ local $Test::Builder::Level = 0;
+
+ $test->is_eq($prem, "", "run pass no prem");
+ $test->is_num(scalar (@results), 1, "run pass result count");
+
+ my $res = $results[0];
+
+ $test->is_eq($res->{name}, "run pass", "run pass name");
+ $test->is_eq($res->{ok}, 1, "run pass ok");
+ $test->is_eq($res->{actual_ok}, 1, "run pass actual_ok");
+ $test->is_eq($res->{reason}, "", "run pass reason");
+ $test->is_eq($res->{type}, "", "run pass type");
+ $test->is_eq($res->{diag}, "", "run pass diag");
+ $test->is_num($res->{depth}, 0, "run pass depth");
+}
+
+{
+ my ($prem, @results) = run_tests(
+ sub {$cap->ok(0, "run fail")}
+ );
+
+ local $Test::Builder::Level = 0;
+
+ $test->is_eq($prem, "", "run fail no prem");
+ $test->is_num(scalar (@results), 1, "run fail result count");
+
+ my $res = $results[0];
+
+ $test->is_eq($res->{name}, "run fail", "run fail name");
+ $test->is_eq($res->{actual_ok}, 0, "run fail actual_ok");
+ $test->is_eq($res->{ok}, 0, "run fail ok");
+ $test->is_eq($res->{reason}, "", "run fail reason");
+ $test->is_eq($res->{type}, "", "run fail type");
+ $test->is_eq($res->{diag}, "", "run fail diag");
+ $test->is_num($res->{depth}, 0, "run fail depth");
+}
+
+{
+ my ($prem, @results) = run_tests(
+ sub {$cap->skip("just because")}
+ );
+
+ local $Test::Builder::Level = 0;
+
+ $test->is_eq($prem, "", "skip no prem");
+ $test->is_num(scalar (@results), 1, "skip result count");
+
+ my $res = $results[0];
+
+ $test->is_eq($res->{name}, "", "skip name");
+ $test->is_eq($res->{actual_ok}, 1, "skip actual_ok");
+ $test->is_eq($res->{ok}, 1, "skip ok");
+ $test->is_eq($res->{reason}, "just because", "skip reason");
+ $test->is_eq($res->{type}, "skip", "skip type");
+ $test->is_eq($res->{diag}, "", "skip diag");
+ $test->is_num($res->{depth}, 0, "skip depth");
+}
+
+{
+ my ($prem, @results) = run_tests(
+ sub {$cap->todo_skip("just because")}
+ );
+
+ local $Test::Builder::Level = 0;
+
+ $test->is_eq($prem, "", "todo_skip no prem");
+ $test->is_num(scalar (@results), 1, "todo_skip result count");
+
+ my $res = $results[0];
+
+ $test->is_eq($res->{name}, "", "todo_skip name");
+ $test->is_eq($res->{actual_ok}, 0, "todo_skip actual_ok");
+ $test->is_eq($res->{ok}, 1, "todo_skip ok");
+ $test->is_eq($res->{reason}, "just because", "todo_skip reason");
+ $test->is_eq($res->{type}, "todo_skip", "todo_skip type");
+ $test->is_eq($res->{diag}, "", "todo_skip diag");
+ $test->is_num($res->{depth}, 0, "todo_skip depth");
+}
+
+{
+ my ($prem, @results) = run_tests(
+ sub {$cap->diag("run diag")}
+ );
+
+ local $Test::Builder::Level = 0;
+
+ $test->is_eq($prem, "run diag\n", "run diag prem");
+ $test->is_num(scalar (@results), 0, "run diag result count");
+}
+
+{
+ my ($prem, @results) = run_tests(
+ sub {
+ $cap->ok(1, "multi pass");
+ $cap->diag("multi pass diag1");
+ $cap->diag("multi pass diag2");
+ $cap->ok(0, "multi fail");
+ $cap->diag("multi fail diag");
+ }
+ );
+
+ local $Test::Builder::Level = 0;
+
+ $test->is_eq($prem, "", "run multi no prem");
+ $test->is_num(scalar (@results), 2, "run multi result count");
+
+ my $res_pass = $results[0];
+
+ $test->is_eq($res_pass->{name}, "multi pass", "run multi pass name");
+ $test->is_eq($res_pass->{actual_ok}, 1, "run multi pass actual_ok");
+ $test->is_eq($res_pass->{ok}, 1, "run multi pass ok");
+ $test->is_eq($res_pass->{reason}, "", "run multi pass reason");
+ $test->is_eq($res_pass->{type}, "", "run multi pass type");
+ $test->is_eq($res_pass->{diag}, "multi pass diag1\nmulti pass diag2\n",
+ "run multi pass diag");
+ $test->is_num($res_pass->{depth}, 0, "run multi pass depth");
+
+ my $res_fail = $results[1];
+
+ $test->is_eq($res_fail->{name}, "multi fail", "run multi fail name");
+ $test->is_eq($res_pass->{actual_ok}, 1, "run multi fail actual_ok");
+ $test->is_eq($res_fail->{ok}, 0, "run multi fail ok");
+ $test->is_eq($res_pass->{reason}, "", "run multi fail reason");
+ $test->is_eq($res_pass->{type}, "", "run multi fail type");
+ $test->is_eq($res_fail->{diag}, "multi fail diag\n", "run multi fail diag");
+ $test->is_num($res_pass->{depth}, 0, "run multi fail depth");
+}
+
test_out("not ok 1 - name # TODO Something");
test_out("# Failed (TODO) test ($0 at line 56)");
-TODO: {
+TODO: {
local $TODO = "Something";
fail("name");
}
# create temporary file handles that still point indirectly
# to the right place
-my $orig_o = gensym;
+my $orig_o = gensym;
my $orig_t = gensym;
-my $orig_f = gensym;
+my $orig_f = gensym;
tie *$orig_o, "My::Passthru", \*STDOUT;
tie *$orig_t, "My::Passthru", \*STDERR;
my $text = shift;
local $^W = 0;
- # reset the outputs
+ # reset the outputs
$t->output($original_output_handle);
$t->failure_output($original_failure_handle);
$t->todo_output($original_todo_handle);
my $text = shift;
local $^W = 0;
- # reset the outputs
+ # reset the outputs
$t->output($original_output_handle);
$t->failure_output($original_failure_handle);
$t->todo_output($original_todo_handle);
{
# rt.cpan.org 11623
- # Make sure the circular ref checks don't get confused by a reference
+ # Make sure the circular ref checks don't get confused by a reference
# which is simply repeating.
my $a = {};
my $b = {};
sub try_cmp_ok {
my($left, $cmp, $right, $error) = @_;
-
+
my %expect;
if( $error ) {
$expect{ok} = 0;
eval { $ok = cmp_ok($left, $cmp, $right, "cmp_ok"); };
$TB->is_num(!!$ok, !!$expect{ok}, " right return");
-
+
my $diag = $err->read;
if ($@) {
use Test::More tests => 2;
+$handler_called = 0;
ok !eval { die };
is $handler_called, 1, 'existing DIE handler not overridden';
# bugs.perl.org 36354
my $ref = \2;
ok( eq_set( [$ref, "$ref", "$ref", $ref],
- ["$ref", $ref, $ref, "$ref"]
+ ["$ref", $ref, $ref, "$ref"]
) );
TODO: {
my $Orig_Dir = cwd;
my $Perl = File::Spec->rel2abs($^X);
-if( $^O eq 'VMS' ) {
- # VMS can't use its own $^X in a system call until almost 5.8
- $Perl = "MCR $^X" if $] < 5.007003;
-
- # Quiet noisy 'SYS$ABORT'
- $Perl .= q{ -"I../lib"} if $ENV{PERL_CORE};
- $Perl .= q{ -"Mvmsish=hushed"};
-}
-
eval { require POSIX; &POSIX::WEXITSTATUS(0) };
if( $@ ) {
for my $exit (0..255) {
# This correctly emulates Test::Builder's behavior.
- my $out = qx[$Perl exit_map_test $exit];
+ my $out = qx["$Perl" exit_map_test $exit];
$TB->like( $out, qr/^exit $exit\n/, "exit map test for $exit" );
$Exit_Map{$exit} = exitstatus($?);
}
my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests));
while( my($test_name, $exit_code) = each %Tests ) {
my $file = File::Spec->catfile($lib, $test_name);
- my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file});
+ my $wait_stat = system(qq{"$Perl" -"I../blib/lib" -"I../lib" -"I../t/lib" $file});
my $actual_exit = exitstatus($wait_stat);
if( $exit_code eq 'not zero' ) {
"(expected non-zero)");
}
else {
- $TB->is_num( $actual_exit, $Exit_Map{$exit_code},
+ $TB->is_num( $actual_exit, $Exit_Map{$exit_code},
"$test_name exited with $actual_exit ".
"(expected $Exit_Map{$exit_code})");
}
use Test::Builder;
use Test::Builder::NoOutput;
-use Test::Simple;
+use Test::More;
my $TB = Test::Builder->new;
my $test = Test::Builder::NoOutput->create;
# at $0 line 45.
END
-$test->_ending();
-$TB->is_eq($test->read(), <<END);
+SKIP: {
+ skip 'Broken with new stuff' => 1;
+ $test->_ending();
+ $TB->is_eq($test->read(), <<' END');
# Looks like you planned 3 tests but ran 5.
# Looks like you failed 2 tests of 5 run.
-END
+ END
+}
$TB->done_testing(5);
# This has to be a require or else the END block below runs before
# Test::Builder's own and the ending diagnostics don't come out right.
require Test::Builder;
-my $TB = Test::Builder->create;
+my $TB = Test::Builder->create();
$TB->plan(tests => 4);
}
-END {
- # Test::More thinks it failed. Override that.
- exit(scalar grep { !$_ } $TB->summary);
-}
+# Test::More thinks it failed. Override that.
+Test::Builder->new->no_ending(1);
$TB->plan(tests => 80);
sub like ($$;$) {
+ my $c = Test::Stream::Context::context();
$TB->like(@_);
}
sub is ($$;$) {
+ my $c = Test::Stream::Context::context();
$TB->is_eq(@_);
}
sub main::out_ok ($$) {
+ my $c = Test::Stream::Context::context();
$TB->is_eq( $out->read, shift );
$TB->is_eq( $err->read, shift );
}
sub main::out_like ($$) {
+ my $c = Test::Stream::Context::context();
my($output, $failure) = @_;
$TB->like( $out->read, qr/$output/ );
OUT
# Failed test 'ARRAY->can('foo')'
# at $0 line 228.
-# ARRAY->can('foo') failed
+# ARRAY->can('foo') failed with an exception:
+# Can't call method "can" on unblessed reference.
ERR
#line 238
OUT
# Failed test 'An object of class 'Foo' isa 'Wibble''
# at $0 line 238.
-# The object of class 'Foo' isn't a 'Wibble'
+# An object of class 'Foo' isn't a 'Wibble'
ERR
#line 248
OUT
# Failed test 'A reference of type 'ARRAY' isa 'HASH''
# at $0 line 268.
-# The reference of type 'ARRAY' isn't a 'HASH'
+# A reference of type 'ARRAY' isn't a 'HASH'
ERR
#line 278
OUT
# Failed test 'A reference of type 'HASH' isa 'Bar''
# at $0 line 313.
-# The reference of type 'HASH' isn't a 'Bar'
+# A reference of type 'HASH' isn't a 'Bar'
ERR
#line 323
OUT
# Failed test 'An object of class 'Wibble' isa 'Baz''
# at $0 line 323.
-# The object of class 'Wibble' isn't a 'Baz'
+# An object of class 'Wibble' isn't a 'Baz'
ERR
#line 333
my $Can_Fork = $Config{d_fork} ||
(($^O eq 'MSWin32' || $^O eq 'NetWare') and
- $Config{useithreads} and
+ $Config{useithreads} and
$Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
);
if( !$Can_Fork ) {
plan skip_all => "This system cannot fork";
}
+elsif ($^O eq 'MSWin32' && $] == 5.010000) {
+ plan 'skip_all' => "5.10 has fork/threading issues that break fork on win32";
+}
else {
plan tests => 1;
}
-if( fork ) { # parent
+my $pid = fork;
+if( $pid ) { # parent
pass("Only the parent should process the ending, not the child");
+ waitpid($pid, 0);
}
else {
exit; # child
--- /dev/null
+use strict;
+use warnings;
+
+use Config;
+
+BEGIN {
+ my $Can_Fork = $Config{d_fork} ||
+ (($^O eq 'MSWin32' || $^O eq 'NetWare') and
+ $Config{useithreads} and
+ $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
+ );
+
+ if( !$Can_Fork ) {
+ require Test::More;
+ Test::More::plan(skip_all => "This system cannot fork");
+ exit 0;
+ }
+ elsif ($^O eq 'MSWin32' && $] == 5.010000) {
+ require Test::More;
+ Test::More::plan('skip_all' => "5.10 has fork/threading issues that break fork on win32");
+ exit 0;
+ }
+}
+
+use Test::Stream 'enable_fork';
+use Test::More;
+# This just goes to show how silly forking inside a subtest would actually
+# be....
+
+ok(1, "fine $$");
+
+my $pid;
+subtest my_subtest => sub {
+ ok(1, "inside 1 | $$");
+ $pid = fork();
+ ok(1, "inside 2 | $$");
+};
+
+if($pid) {
+ waitpid($pid, 0);
+
+ ok(1, "after $$");
+
+ done_testing;
+}
{
local $ENV{HARNESS_ACTIVE} = 1;
-
+
#line 71
fail( "this fails" );
err_ok( <<ERR );
#line 88
ok !is_deeply({ this => 42 }, { this => 43 }, 'hashes with different values');
-is( $out, "not ok 3 - hashes with different values\n",
+is( $out, "not ok 3 - hashes with different values\n",
'hashes with different values' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'hashes with different values'
local $SIG{__WARN__} = sub { $warning .= join '', @_; };
ok !is_deeply(@$test);
- like \$warning,
+ like \$warning,
"/^is_deeply\\(\\) takes two or three args, you gave $num_args\.\n/";
}
use Config;
BEGIN {
- unless ( $] >= 5.008001 && $Config{'useithreads'} &&
- eval { require threads; 'threads'->import; 1; })
- {
+ if ($] == 5.010000) {
+ print "1..0 # Threads are broken on 5.10.0\n";
+ exit 0;
+ }
+
+ my $works = 1;
+ $works &&= $] >= 5.008001;
+ $works &&= $Config{'useithreads'};
+ $works &&= eval { require threads; 'threads'->import; 1 };
+
+ unless ($works) {
print "1..0 # Skip no working threads\n";
exit 0;
}
-
+
unless ( $ENV{AUTHOR_TESTING} ) {
print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n";
exit 0;
}
}
+
use Test::More;
my $Num_Threads = 5;
eval {
new_ok();
};
-is $@, sprintf "new_ok() must be given at least a class at %s line %d.\n", $0, __LINE__ - 2;
+my $error = $@;
+$error =~ s/\.?\n.*$//gsm;
+is $error, sprintf "new_ok() must be given at least a class at %s line %d", $0, __LINE__ - 4;
package Foo;
::is_deeply(['TestPackage'], ['TestPackage']);
- ::is_deeply({'TestPackage' => 'TestPackage'},
+ ::is_deeply({'TestPackage' => 'TestPackage'},
{'TestPackage' => 'TestPackage'});
::is_deeply('TestPackage', 'TestPackage');
}
plan tests => 4;
eval { plan tests => 4 };
-is( $@, sprintf("You tried to plan twice at %s line %d.\n", $0, __LINE__ - 1),
+is( $@, sprintf("Tried to plan twice!\n %s line %d\n %s line %d\n", $0, __LINE__ - 2, $0, __LINE__ - 1),
'disallow double plan' );
eval { plan 'no_plan' };
-is( $@, sprintf("You tried to plan twice at %s line %d.\n", $0, __LINE__ -1),
+is( $@, sprintf("Tried to plan twice!\n %s line %d\n %s line %d\n", $0, __LINE__ - 5, $0, __LINE__ - 1),
'disallow changing plan' );
pass('Just testing plan()');
use Test::More;
BEGIN {
+ require warnings;
+ if( eval "warnings->can('carp')" ) {
+ plan skip_all => 'Modern::Open is installed, which breaks this test';
+ }
if( !$ENV{HARNESS_ACTIVE} && $ENV{PERL_CORE} ) {
plan skip_all => "Won't work with t/TEST";
}
--- /dev/null
+#!/usr/bin/perl -w
+
+use Test::More;
+plan skip_all => "POD tests skipped unless AUTHOR_TESTING is set" unless $ENV{AUTHOR_TESTING};
+my $test_pod = eval "use Test::Pod 1.00; 1";
+plan skip_all => "Test::Pod 1.00 required for testing POD" unless $test_pod;
+all_pod_files_ok();
}
use strict;
-use Test::More tests => 8;
+use Test::More tests => 4;
# Symbol and Class::Struct are both non-XS core modules back to 5.004.
# So they'll always be there.
require_ok("Class/Struct.pm");
ok( $INC{'Class/Struct.pm'}, "require_ok FILE" );
-
-# Its more trouble than its worth to try to create these filepaths to test
-# through require_ok() so we cheat and use the internal logic.
-ok !Test::More::_is_module_name('foo:bar');
-ok !Test::More::_is_module_name('foo/bar.thing');
-ok !Test::More::_is_module_name('Foo::Bar::');
-ok Test::More::_is_module_name('V');
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ my $has_module = eval { require SQL::Abstract::Test; 1 };
+ my $required = $ENV{AUTHOR_TESTING};
+
+ if ($required && !$has_module) {
+ die "This test requires 'SQL::Abstract::Test' to be installed when AUTHOR_TESTING.\n";
+ }
+
+ unless($required) {
+ plan skip_all => "Only run when AUTHOR_TESTING is set";
+ }
+}
+
+{
+ package Worker;
+
+ sub do_work {
+ local $Test::Builder::Level = $Test::Builder::Level + 2;
+ shift->();
+ }
+}
+
+use SQL::Abstract::Test;
+use Test::Stream::Tester;
+
+my $events = intercept {
+ local $TODO = "Not today";
+
+ Worker::do_work(
+ sub {
+ SQL::Abstract::Test::is_same_sql_bind(
+ 'buh', [],
+ 'bah', [1],
+ );
+ }
+ );
+};
+
+ok( !(grep { $_->context->in_todo ? 0 : 1 } @{$events->[0]->diag}), "All diag is todo" );
+
+events_are(
+ $events,
+ check {
+ event ok => {
+ in_todo => 1,
+ };
+ event note => { in_todo => 1 };
+ event note => { in_todo => 1 };
+ dir 'end';
+ },
+ "All events are TODO"
+);
+
+done_testing;
--- /dev/null
+use Config;
+
+BEGIN {
+ if ($] == 5.010000) {
+ print "1..0 # Threads are broken on 5.10.0\n";
+ exit 0;
+ }
+
+ my $works = 1;
+ $works &&= $] >= 5.008001;
+ $works &&= $Config{'useithreads'};
+ $works &&= eval { require threads; 'threads'->import; 1 };
+
+ unless ($works) {
+ print "1..0 # Skip no working threads\n";
+ exit 0;
+ }
+
+ unless ($ENV{AUTHOR_TESTING}) {
+ print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n";
+ exit 0;
+ }
+
+ if ($INC{'Devel/Cover.pm'}) {
+ print "1..0 # SKIP Devel::Cover does not work with threads yet\n";
+ exit 0;
+ }
+}
+
+use threads;
+
+use strict;
+use warnings;
+
+use Test::More;
+
+# basic tests
+{
+ pass('Test starts');
+ my $ct_num = Test::More->builder->current_test;
+
+ my $newthread = async {
+ my $out = '';
+
+ #simulate a subtest to not confuse the parent TAP emission
+ my $tb = Test::More->builder;
+ $tb->reset;
+
+ Test::More->builder->current_test(0);
+ for (qw/output failure_output todo_output/) {
+ close $tb->$_;
+ open($tb->$_, '>', \$out);
+ }
+
+ pass("In-thread ok") for (1, 2, 3);
+
+ done_testing;
+
+ close $tb->$_ for (qw/output failure_output todo_output/);
+ sleep(1); # tasty crashes without this
+
+ $out;
+ };
+ die "Thread creation failed: $! $@" if !defined $newthread;
+
+ my $out = $newthread->join;
+ $out =~ s/^/ /gm;
+
+ print $out;
+
+ # workaround for older Test::More confusing the plan under threads
+ Test::More->builder->current_test($ct_num);
+
+ pass("Made it to the end");
+}
+
+done_testing;
--- /dev/null
+use Config;
+
+BEGIN {
+ if ($] == 5.010000) {
+ print "1..0 # Threads are broken on 5.10.0\n";
+ exit 0;
+ }
+
+ my $works = 1;
+ $works &&= $] >= 5.008001;
+ $works &&= $Config{'useithreads'};
+ $works &&= eval { require threads; 'threads'->import; 1 };
+
+ unless ($works) {
+ print "1..0 # Skip no working threads\n";
+ exit 0;
+ }
+
+ unless ($ENV{AUTHOR_TESTING}) {
+ print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n";
+ exit 0;
+ }
+
+ if ($INC{'Devel/Cover.pm'}) {
+ print "1..0 # SKIP Devel::Cover does not work with threads yet\n";
+ exit 0;
+ }
+}
+
+use threads;
+
+use strict;
+use warnings;
+
+use Test::More;
+
+{
+ my $todo = sub {
+ my $out;
+ ok(1);
+ 42;
+ };
+
+ is(
+ threads->create($todo)->join,
+ 42,
+ "Correct result after do-er",
+ );
+}
+
+done_testing;
}
}
-use Test::More tests => 17;
+BEGIN {
+ require warnings;
+ if( eval "warnings->can('carp')" ) {
+ require Test::More;
+ Test::More::plan( skip_all => 'Modern::Open is installed, which breaks this test' );
+ }
+}
+
+use Test::More tests => 16;
# If we skip with the same name, Test::Harness will report it back and
# we won't get lots of false bug reports.
my $Why = "Just testing the skip interface.";
SKIP: {
- skip $Why, 2
+ skip $Why, 2
unless Pigs->can('fly');
my $pig = Pigs->new;
fail("So very failed");
}
is( $warning, "skip() needs to know \$how_many tests are in the ".
- "block at $0 line 56\n",
+ "block at $0 line 56.\n",
'skip without $how_many warning' );
}
else {
unshift @INC, 't/lib';
}
-}
+}
use strict;
--- /dev/null
+#!/usr/bin/perl -w
+
+# Check that stray newlines in test output are properly handed.
+
+BEGIN {
+ print "1..0 # Skip not completed\n";
+ exit 0;
+}
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
+chdir 't';
+
+use Test::Builder::NoOutput;
+my $tb = Test::Builder::NoOutput->create;
+
+$tb->ok(1, "name\n");
+$tb->ok(0, "foo\nbar\nbaz");
+$tb->skip("\nmoofer");
+$tb->todo_skip("foo\n\n");
$tb->ok( !eval { $tb->subtest("foo") } );
$tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ );
+use Carp qw/confess/;
$tb->subtest('Arg passing', sub {
my $foo = shift;
my $child = Test::Builder->new;
my $Exit_Code;
BEGIN {
- *CORE::GLOBAL::exit = sub { $Exit_Code = shift; };
+ *CORE::GLOBAL::exit = sub { $Exit_Code = shift; die };
}
use Test::Builder;
plan tests => 4;
ok 'foo';
-subtest 'bar' => sub {
- plan tests => 3;
- ok 'sub_foo';
- subtest 'sub_bar' => sub {
+my $ok = eval {
+ subtest 'bar' => sub {
plan tests => 3;
- ok 'sub_sub_foo';
- ok 'sub_sub_bar';
- BAIL_OUT("ROCKS FALL! EVERYONE DIES!");
- ok 'sub_sub_baz';
+ ok 'sub_foo';
+ subtest 'sub_bar' => sub {
+ plan tests => 3;
+ ok 'sub_sub_foo';
+ ok 'sub_sub_bar';
+ BAIL_OUT("ROCKS FALL! EVERYONE DIES!");
+ ok 'sub_sub_baz';
+ };
+ ok 'sub_baz';
};
- ok 'sub_baz';
+ 1;
};
$Test->is_eq( $output, <<'OUT' );
1..4
ok 1
- # Subtest: bar
+# Subtest: bar
1..3
ok 1
- # Subtest: sub_bar
+ # Subtest: sub_bar
1..3
ok 1
ok 2
+ Bail out! ROCKS FALL! EVERYONE DIES!
+ Bail out! ROCKS FALL! EVERYONE DIES!
Bail out! ROCKS FALL! EVERYONE DIES!
OUT
use Test::Builder::NoOutput;
-use Test::More tests => 19;
+use Test::More tests => 18;
# Formatting may change if we're running under Test::Harness.
$ENV{HARNESS_ACTIVE} = 0;
my $child = $tb->child('skippy says he loves you');
eval { $child->plan( skip_all => 'cuz I said so' ) };
ok my $error = $@, 'A child which does a "skip_all" should throw an exception';
- isa_ok $error, 'Test::Builder::Exception', '... and the exception it throws';
+ isa_ok $error, 'Test::Stream::Event', '... and the exception it throws';
}
subtest 'skip all', sub {
plan skip_all => 'subtest with skip_all';
ok 0, 'This should never be run';
};
- is +Test::Builder->new->{Test_Results}[-1]{type}, 'skip',
- 'Subtests which "skip_all" are reported as skipped tests';
}
# to do tests
$tb->_ending;
my $expected = <<"END";
1..1
-not ok 1 - No tests run for subtest "Child of $0"
+not ok 1 - Child of $0
+# Failed test 'Child of $0'
+# at $0 line 225.
+# No tests run for subtest.
END
like $tb->read, qr/\Q$expected/,
'Not running subtests should make the parent test fail';
});
1;
});
- $Test->like( $@, qr/^Death in the subtest at $0 line /);
+ $Test->like( $@, qr/^Death in the subtest at \Q$0\E line /);
$Test->ok( !$tb->parent, "the parent object is restored after a die" );
}
pass("First");
-my $file = "t/subtest/for_do_t.test";
+my $file = "t/Legacy/subtest/for_do_t.test";
ok -e $file, "subtest test file exists";
subtest $file => sub { do $file };
{
my $tb = Test::Builder::NoOutput->create;
- $tb->child('one');
+ my $child = $tb->child('one');
eval { $tb->child('two') };
my $error = $@;
like $error, qr/\QYou already have a child named (one) running/,
'Trying to create a child with another one active should fail';
+ $child->finalize;
}
{
my $tb = Test::Builder::NoOutput->create;
my $error = $@;
like $error, qr/\QCan't call finalize() with child (two) active/,
'... but trying to finalize() a child with open children should fail';
+ $child2->finalize;
+ $child->finalize;
}
{
my $tb = Test::Builder::NoOutput->create;
my $child = $tb->child('one');
- undef $child;
- like $tb->read, qr/\QChild (one) exited without calling finalize()/,
+ eval { $child->DESTROY };
+ like $@, qr/\QChild (one) exited without calling finalize()/,
'Failing to call finalize should issue an appropriate diagnostic';
ok !$tb->is_passing, '... and should cause the test suite to fail';
+ $child->finalize;
}
{
my $tb = Test::Builder::NoOutput->create;
if( !$Can_Fork ) {
plan 'skip_all' => "This system cannot fork";
}
+elsif ($^O eq 'MSWin32' && $] == 5.010000) {
+ plan 'skip_all' => "5.10 has fork/threading issues that break fork on win32";
+}
else {
plan 'tests' => 1;
}
is $?, 0, 'child exit status';
like $child_output, qr/^[\s#]+Child Done\s*\z/, 'child output';
- }
+ }
else {
$pipe->writer;
# Force all T::B output into the pipe, for the parent
# builder as well as the current subtest builder.
- no warnings 'redefine';
- *Test::Builder::output = sub { $pipe };
- *Test::Builder::failure_output = sub { $pipe };
- *Test::Builder::todo_output = sub { $pipe };
-
+ my $builder = Test::Builder->new;
+ $builder->output($pipe);
+ $builder->failure_output($pipe);
+ $builder->todo_output($pipe);
+
diag 'Child Done';
exit 0;
}
our %line;
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..3");
test_out(" ok 1");
test_out(" not ok 2");
ok 0; BEGIN{ $line{innerfail1} = __LINE__ }
ok 1;
}; BEGIN{ $line{outerfail1} = __LINE__ }
-
+
test_test("un-named inner tests");
}
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..3");
test_out(" ok 1 - first is good");
test_out(" not ok 2 - second is bad");
ok 0, "second is bad"; BEGIN{ $line{innerfail2} = __LINE__ }
ok 1, "third is good";
}; BEGIN{ $line{outerfail2} = __LINE__ }
-
+
test_test("named inner tests");
}
}; BEGIN{ $line{outerfail3} = __LINE__ }
}
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..3");
test_out(" ok 1 - first is good");
test_out(" not ok 2 - second is bad");
test_err("# at $0 line $line{outerfail3}.");
run_the_subtest();
-
+
test_test("subtest() called from a sub");
}
{
- test_out( " # Subtest: namehere");
+ test_out( "# Subtest: namehere");
test_out( " 1..0");
test_err( " # No tests run!");
- test_out( 'not ok 1 - No tests run for subtest "namehere"');
- test_err(q{# Failed test 'No tests run for subtest "namehere"'});
+ test_out( 'not ok 1 - namehere');
+ test_err(q{# Failed test 'namehere'});
test_err( "# at $0 line $line{outerfail4}.");
+ test_err( "# No tests run for subtest.");
subtest namehere => sub {
done_testing;
test_test("lineno in 'No tests run' diagnostic");
}
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..1");
test_out(" not ok 1 - foo is bar");
test_err(" # Failed test 'foo is bar'");
};
}
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..2");
test_out(" ok 1 - foo");
test_out(" not ok 2 - bar");
foobar_ok($value, $name);
}
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..2");
test_out(" ok 1 - foo");
test_out(" not ok 2 - bar");
});
}
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..2");
test_out(" ok 1 - foo");
test_out(" not ok 2 - bar");
barfoo_ok($value, $name);
}
{
- test_out(" # Subtest: namehere");
+ test_out("# Subtest: namehere");
test_out(" 1..2");
test_out(" ok 1 - foo");
test_out(" not ok 2 - bar");
# A subtest-based predicate called from within a subtest
{
- test_out(" # Subtest: outergroup");
+ test_out("# Subtest: outergroup");
test_out(" 1..2");
test_out(" ok 1 - this passes");
- test_out(" # Subtest: namehere");
+ test_out(" # Subtest: namehere");
test_out(" 1..2");
test_out(" ok 1 - foo");
test_out(" not ok 2 - bar");
use Config;
BEGIN {
- unless ( $] >= 5.008001 && $Config{'useithreads'} &&
- eval { require threads; 'threads'->import; 1; })
+ unless ( $] >= 5.008001 && $Config{'useithreads'} &&
+ eval { require threads; 'threads'->import; 1; })
{
print "1..0 # Skip: no working threads\n";
exit 0;
sub test_subtest_in_todo {
my ($name, $code, $want_out, $no_tests_run) = @_;
- my $xxx = $no_tests_run ? 'No tests run for subtest "xxx"' : 'xxx';
+ #my $xxx = $no_tests_run ? 'No tests run for subtest "xxx"' : 'xxx';
+ my @no_test_err = $no_tests_run ? ('# No tests run for subtest.') : ();
chomp $want_out;
my @outlines = split /\n/, $want_out;
my ($set_via, $todo_reason, $level) = @$combo;
test_out(
- " # Subtest: xxx",
+ "# Subtest: xxx",
@outlines,
- "not ok 1 - $xxx # TODO $todo_reason",
- "# Failed (TODO) test '$xxx'",
- "# at $0 line $line{xxx}.",
- "not ok 2 - regular todo test # TODO $todo_reason",
- "# Failed (TODO) test 'regular todo test'",
- "# at $0 line $line{reg}.",
+ map { my $x = $_; $x =~ s/\s+$//; $x } (
+ "not ok 1 - xxx # TODO $todo_reason",
+ "# Failed (TODO) test 'xxx'",
+ "# at $0 line $line{xxx}.",
+ @no_test_err,
+ "not ok 2 - regular todo test # TODO $todo_reason",
+ "# Failed (TODO) test 'regular todo test'",
+ "# at $0 line $line{reg}.",
+ )
);
{
}
}
- test_test("$name ($level), todo [$todo_reason] set via $set_via");
+ last unless test_test("$name ($level), todo [$todo_reason] set via $set_via");
}
}
package Foo; # If several stack frames are in package 'main' then $Level
# could be wrong and $main::TODO might still be found. Using
# another package makes the tests more sensitive.
-
+
sub main::subtest_at_level {
my ($name, $code, $level) = @_;
use strict;
use warnings;
-# Can't use Test::More, that would set exported_to()
+# Can't use Test::More that would set exported_to()
use Test::Builder;
use Test::Builder::Module;
--- /dev/null
+use strict;
+use Test::More;
+use ok;
+use ok 'strict';
+use ok 'Test::More';
+use ok 'ok';
+
+my $class = 'Test::Builder';
+BEGIN {
+ ok(!$class, '$class is declared, but not yet set');
+
+
+ my $success = eval 'use ok $class';
+ my $error = $@;
+
+ ok(!$success, "Threw an exception");
+ like(
+ $error,
+ qr/^'use ok' called with an empty argument, did you try to use a package name from an uninitialized variable\?/,
+ "Threw expected exception"
+ );
+
+
+
+ $success = eval 'use ok $class, "xxx"';
+ $error = $@;
+
+ ok(!$success, "Threw an exception");
+ like(
+ $error,
+ qr/^'use ok' called with an empty argument, did you try to use a package name from an uninitialized variable\?/,
+ "Threw expected exception when arguments are added"
+ );
+}
+
+my $class2;
+BEGIN {$class2 = 'Test::Builder'};
+use ok $class2;
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if ($] == 5.010000) {
+ print "1..0 # Threads are broken on 5.10.0\n";
+ exit 0;
+ }
+
+ my $works = 1;
+ $works &&= $] >= 5.008001;
+ $works &&= $Config{'useithreads'};
+ $works &&= eval { require threads; 'threads'->import; 1 };
+
+ unless ($works) {
+ print "1..0 # Skip no working threads\n";
+ exit 0;
+ }
+
+ unless ( $ENV{AUTHOR_TESTING} ) {
+ print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n";
+ exit 0;
+ }
+}
+
+use strict;
+use Test::Builder;
+
+my $Test = Test::Builder->new;
+$Test->exported_to('main');
+$Test->plan(tests => 6);
+
+for(1..5) {
+ 'threads'->create(sub {
+ $Test->ok(1,"Each of these should app the test number")
+ })->join;
+}
+
+$Test->is_num($Test->current_test(), 5,"Should be five");
use Test::More;
+BEGIN {
+ require warnings;
+ if( eval "warnings->can('carp')" ) {
+ plan skip_all => 'Modern::Open is installed, which breaks this test';
+ }
+}
+
plan tests => 36;
fail("So very failed");
}
is( $warning, "todo_skip() needs to know \$how_many tests are in the ".
- "block at $0 line 74\n",
+ "block at $0 line 74.\n",
'todo_skip without $how_many warning' );
}
my $exported_to = $builder->exported_to;
TODO: {
$builder->exported_to("Wibble");
-
+
local $TODO = "testing \$TODO with an incorrect exported_to()";
-
+
fail("Just testing todo");
}
ok $in_todo, " but we're in_todo()";
}
+# line 200
eval {
$builder->todo_end;
};
}
use strict;
-use Test::More tests => 21;
+use Test::More;
+
+BEGIN {
+ require warnings;
+ if( eval "warnings->can('carp')" ) {
+ plan skip_all => 'Modern::Open is installed, which breaks this test';
+ }
+}
BEGIN { $^W = 1; }
my $Filename = quotemeta $0;
-
+
is( undef, undef, 'undef is undef');
no_warnings;
is_deeply([ undef ], [ undef ]);
no_warnings;
}
+
+done_testing;
for my $method (keys %handles) {
my $src = $handles{$method};
-
+
my $dest = Test::More->builder->$method;
-
+
is_deeply { map { $_ => 1 } PerlIO::get_layers($dest) },
{ map { $_ => 1 } PerlIO::get_layers($src) },
"layers copied to $method";
# Test utf8 is ok.
{
my $uni = "\x{11e}";
-
+
my @warnings;
local $SIG{__WARN__} = sub {
push @warnings, @_;
--- /dev/null
+#!/usr/bin/perl -w
+
+# Make sure all the modules have the same version
+#
+# TBT has its own version system.
+
+use strict;
+use Test::More;
+
+{
+ local $SIG{__WARN__} = sub { 1 };
+ require Test::Builder::Module;
+ require Test::Builder::Tester::Color;
+ require Test::Builder::Tester;
+ require Test::Builder;
+ require Test::More;
+ require Test::Simple;
+ require Test::Stream;
+ require Test::Stream::Tester;
+ require Test::Tester;
+ require Test::use::ok;
+ require ok;
+}
+
+my $dist_version = Test::More->VERSION;
+
+like( $dist_version, qr/^ \d+ \. \d+ $/x, "Version number is sane" );
+
+my @modules = qw(
+ Test::Builder::Module
+ Test::Builder::Tester::Color
+ Test::Builder::Tester
+ Test::Builder
+ Test::More
+ Test::Simple
+ Test::Stream
+ Test::Stream::Tester
+ Test::Tester
+ Test::use::ok
+ ok
+);
+
+for my $module (@modules) {
+ my $file = $module;
+ $file =~ s{(::|')}{/}g;
+ $file .= ".pm";
+ is( $module->VERSION, $module->VERSION, sprintf("%-22s %s", $module, $INC{$file}) );
+}
+
+done_testing();
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use ok 'Test::Builder';
+
+# Test::Builder is tested by the stuff in t/Legacy
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use ok 'Test::More::DeepCheck';
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use ok 'Test::More';
+
+{
+ package Foo;
+ use Test::More import => ['!explain'];
+}
+
+{
+ package Bar;
+ BEGIN { main::use_ok('Scalar::Util', 'blessed') }
+ BEGIN { main::can_ok('Bar', qw/blessed/) }
+ blessed('x');
+}
+
+{
+ package Baz;
+ use Test::More;
+ use_ok( 'Data::Dumper' );
+ can_ok( __PACKAGE__, 'Dumper' );
+ Dumper({foo => 'bar'});
+}
+
+can_ok('Foo', qw/ok is plan/);
+ok(!Foo->can('explain'), "explain was not imported");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Stream;
+use Test::MostlyLike;
+use Test::More;
+use Test::Stream::Tester;
+
+use ok 'Test::MostlyLike';
+
+{
+ package XXX;
+
+ sub new { bless {ref => ['a']}, shift };
+
+ sub numbers { 1 .. 10 };
+ sub letters { 'a' .. 'e' };
+ sub ref { [ 1 .. 10 ] };
+}
+
+events_are (
+ intercept {
+ mostly_like( 'a', 'a', "match" );
+ mostly_like( 'a', 'b', "no match" );
+
+ mostly_like(
+ [ qw/a b c/ ],
+ [ qw/a b c/ ],
+ "all match",
+ );
+
+ mostly_like(
+ [qw/a b c/],
+ { 1 => 'b' },
+ "Only check one index (match)",
+ );
+ mostly_like(
+ [qw/a b c/],
+ { 1 => 'x' },
+ "Only check one index (no match)",
+ );
+
+ mostly_like(
+ { a => 1, b => 2, c => 3 },
+ { a => 1, b => 2, c => 3 },
+ "all match"
+ );
+
+ mostly_like(
+ { a => 1, b => 2, c => 3 },
+ { b => 2, d => undef },
+ "A match and an expected empty"
+ );
+
+ mostly_like(
+ { a => 1, b => 2, c => 3 },
+ { b => undef },
+ "Expect empty (fail)"
+ );
+
+ mostly_like(
+ { a => 'foo', b => 'bar' },
+ { a => qr/o/, b => qr/a/ },
+ "Regex check"
+ );
+
+ mostly_like(
+ { a => 'foo', b => 'bar' },
+ { a => qr/o/, b => qr/o/ },
+ "Regex check fail"
+ );
+
+ mostly_like(
+ { a => { b => { c => { d => 1 }}}},
+ { a => { b => { c => { d => 1 }}}},
+ "Deep match"
+ );
+
+ mostly_like(
+ { a => { b => { c => { d => 1 }}}},
+ { a => { b => { c => { d => 2 }}}},
+ "Deep mismatch"
+ );
+
+ mostly_like(
+ XXX->new,
+ {
+ ':ref' => ['a'],
+ ref => [ 1 .. 10 ],
+ '[numbers]' => [ 1 .. 10 ],
+ '[letters]' => [ 'a' .. 'e' ],
+ },
+ "Object check"
+ );
+
+ mostly_like(
+ XXX->new,
+ {
+ ':ref' => ['a'],
+ ref => [ 1 .. 10 ],
+ '[numbers]' => [ 1 .. 10 ],
+ '[letters]' => [ 'a' .. 'e' ],
+ '[invalid]' => [ 'x' ],
+ },
+ "Object check"
+ );
+
+ },
+ check {
+ event ok => { bool => 1 };
+ event ok => {
+ bool => 0,
+ diag => qr/got: 'a'.*\n.*expected: 'b'/,
+ };
+
+ event ok => { bool => 1 };
+ event ok => { bool => 1 };
+
+ event ok => {
+ bool => 0,
+ diag => qr/\$got->\[1\] = 'b'\n\s*\$expected->\[1\] = 'x'/,
+ };
+
+ event ok => { bool => 1 };
+ event ok => { bool => 1 };
+
+ event ok => {
+ bool => 0,
+ diag => qr/\$got->\{b\} = '2'\n\s*\$expected->\{b\} = undef/,
+ };
+
+ event ok => { bool => 1 };
+ event ok => {
+ bool => 0,
+ diag => qr/\$got->\{b\} = 'bar'\n\s+\$expected->\{b\} = .*o/,
+ };
+
+ event ok => { bool => 1 };
+ event ok => {
+ bool => 0,
+ diag => qr/\$got->\Q{a}{b}{c}{d}\E = '1'\n\s+\$expected->\Q{a}{b}{c}{d}\E = '2'/,
+ };
+
+ event ok => { bool => 1 };
+ event ok => {
+ bool => 0,
+ diag => [
+ qr/\[\s+\$got->invalid\(\)\] = '\(EXCEPTION\)'/,
+ qr/\[\$expected->\{invalid\}\] = ARRAY/,
+ qr/Can't locate object method "invalid" via package "XXX"/,
+ ],
+ };
+
+ directive 'end';
+ },
+ "Tolerant"
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Simple tests => 1;
+use Test::Stream::Tester;
+
+events_are (
+ intercept {
+ ok(1, "Pass");
+ ok(0, "Fail");
+ },
+ check {
+ event ok => {
+ bool => 1,
+ name => 'Pass',
+ diag => '',
+ };
+ event ok => {
+ bool => 0,
+ name => 'Fail',
+ diag => qr/Failed test 'Fail'/,
+ };
+ },
+);
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use ok 'Test::Stream::ArrayBase::Meta';
+
+# This class is tested in the Test::Stream::ArrayBase tests
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib 'lib';
+
+BEGIN {
+ $INC{'My/ABase.pm'} = __FILE__;
+
+ package My::ABase;
+ use Test::Stream::ArrayBase(
+ accessors => [qw/foo bar baz/],
+ );
+
+ use Test::More;
+ is(FOO, 0, "FOO CONSTANT");
+ is(BAR, 1, "BAR CONSTANT");
+ is(BAZ, 2, "BAZ CONSTANT");
+
+ my $bad = eval { Test::Stream::ArrayBase->import( accessors => [qw/foo/] ); 1 };
+ my $error = $@;
+ ok(!$bad, "Threw exception");
+ like($error, qr/field 'foo' already defined/, "Expected error");
+}
+
+BEGIN {
+ package My::ABaseSub;
+ use Test::Stream::ArrayBase(
+ accessors => [qw/apple pear/],
+ base => 'My::ABase',
+ );
+
+ use Test::More;
+ is(FOO, 0, "FOO CONSTANT");
+ is(BAR, 1, "BAR CONSTANT");
+ is(BAZ, 2, "BAZ CONSTANT");
+ is(APPLE, 3, "APPLE CONSTANT");
+ is(PEAR, 4, "PEAR CONSTANT");
+
+ my $bad = eval { Test::Stream::ArrayBase->import( base => 'foobarbaz' ); 1 };
+ my $error = $@;
+ ok(!$bad, "Threw exception");
+ like($error, qr/My::ABaseSub is already a subclass of 'My::ABase'/, "Expected error");
+}
+
+{
+ package My::ABase;
+ my $bad = eval { Test::Stream::ArrayBase->import( accessors => [qw/xerxes/] ); 1 };
+ my $error = $@;
+ ok(!$bad, "Threw exception");
+ like($error, qr/Cannot add accessor, metadata is locked due to a subclass being initialized/, "Expected error");
+}
+
+{
+ package Consumer;
+ use My::ABase qw/BAR/;
+ use Test::More;
+
+ is(BAR, 1, "Can import contants");
+
+ my $bad = eval { Test::Stream::ArrayBase->import( base => 'Test::More' ); 1 };
+ my $error = $@;
+ ok(!$bad, "Threw exception");
+ like($error, qr/Base class 'Test::More' is not a subclass of Test::Stream::ArrayBase/, "Expected error");
+}
+
+isa_ok('My::ABase', 'Test::Stream::ArrayBase');
+isa_ok('My::ABaseSub', 'Test::Stream::ArrayBase');
+isa_ok('My::ABaseSub', 'My::ABase');
+
+my $one = My::ABase->new(qw/a b c/);
+is($one->foo, 'a', "Accessor");
+is($one->bar, 'b', "Accessor");
+is($one->baz, 'c', "Accessor");
+$one->set_foo('x');
+is($one->foo, 'x', "Accessor set");
+$one->set_foo(undef);
+
+is_deeply(
+ $one->to_hash,
+ {
+ foo => undef,
+ bar => 'b',
+ baz => 'c',
+ },
+ 'to_hash'
+);
+
+my $two = My::ABase->new_from_pairs(
+ foo => 'foo',
+ bar => 'bar',
+);
+
+is($two->foo, 'foo', "set by pair");
+is($two->bar, 'bar', "set by pair");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+# On some threaded systems this test cannot be run.
+BEGIN {
+ require Test::Stream::Threads;
+ if ($INC{'Carp.pm'}) {
+ print "1..0 # SKIP: Carp is already loaded before we even begin.\n";
+ exit 0;
+ }
+}
+
+my @stack;
+BEGIN {
+ unshift @INC => sub {
+ my ($ref, $filename) = @_;
+ return if @stack;
+ return unless $filename eq 'Carp.pm';
+ my %seen;
+ my $level = 1;
+ while (my @call = caller($level++)) {
+ my ($pkg, $file, $line) = @call;
+ next if $seen{"$file $line"}++;
+ push @stack => \@call;
+ }
+ return;
+ };
+}
+
+use Test::More;
+
+BEGIN {
+ my $r = ok(!$INC{'Carp.pm'}, "Carp is not loaded when we start");
+}
+
+use ok 'Test::Stream::Carp', 'croak';
+
+ok(!$INC{'Carp.pm'}, "Carp is not loaded");
+
+if (@stack) {
+ my $msg = "Carp load trace:\n";
+ $msg .= " $_->[1] line $_->[2]\n" for @stack;
+ diag $msg;
+}
+
+my $out = eval { croak "xxx"; 1 };
+my $err = $@;
+ok(!$out, "died");
+like($err, qr/xxx/, "Got carp exception");
+
+ok($INC{'Carp.pm'}, "Carp is loaded now");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Stream;
+use Test::More;
+
+use ok 'Test::Stream::Event::Diag';
+
+my $ctx = context(-1); my $line = __LINE__;
+$ctx = $ctx->snapshot;
+is($ctx->line, $line, "usable context");
+
+my $diag = $ctx->diag('hello');
+ok($diag, "build diag");
+isa_ok($diag, 'Test::Stream::Event::Diag');
+is($diag->message, 'hello', "message");
+
+is_deeply(
+ [$diag->to_tap],
+ [[Test::Stream::Event::Diag::OUT_ERR, "# hello\n"]],
+ "Got tap"
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+use ok 'Test::Stream::Event::Finish';
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Stream;
+use Test::More;
+
+use ok 'Test::Stream::Event::Note';
+
+my $note = Test::Stream::Event::Note->new('fake', 'fake', 0, "hello");
+
+is($note->message, 'hello', "got message");
+
+is_deeply(
+ [$note->to_tap],
+ [[Test::Stream::Event::Note::OUT_STD, "# hello\n"]],
+ "Got handle id and message in tap",
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Stream;
+use Test::More;
+
+use ok 'Test::Stream::Event';
+
+can_ok('Test::Stream::Event', qw/context created in_subtest/);
+
+my $ok = eval { Test::Stream::Event->new(); 1 };
+my $err = $@;
+ok(!$ok, "Died");
+like($err, qr/No context provided/, "Need context");
+
+{
+ package My::MockEvent;
+ use Test::Stream::Event(
+ accessors => [qw/foo bar baz/],
+ );
+}
+
+can_ok('My::MockEvent', qw/foo bar baz/);
+isa_ok('My::MockEvent', 'Test::Stream::Event');
+
+my $one = My::MockEvent->new('fake');
+
+can_ok('Test::Stream::Context', 'mockevent');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use ok 'Test::Stream::ExitMagic::Context';
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+use ok 'Test::Stream::Exporter::Meta';
+
+# This is tested by the Test::Stream::Exporter tests.
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+{
+ package My::Exporter;
+ use Test::Stream::Exporter;
+ use Test::More;
+
+ export a => sub { 'a' };
+ default_export b => sub { 'b' };
+
+ export 'c';
+ sub c { 'c' }
+
+ default_export x => sub { 'x' };
+
+ our $export = "here";
+ $main::export::xxx = 'here';
+
+ export '$export' => \$export;
+
+ Test::Stream::Exporter->cleanup;
+
+ is($export, 'here', "still have an \$export var");
+ is($main::export::xxx, 'here', "still have an \$export::* var");
+
+ ok(!__PACKAGE__->can($_), "removed $_\()") for qw/export default_export exports default_exports/;
+
+ my $ok = eval {
+ export no => sub { 'no' };
+ 1;
+ };
+ my $error = $@;
+ ok(!$ok, "Cannot add exports after cleanup");
+ like($error, qr/Undefined subroutine &My::Exporter::export called/, "Sub was removed");
+}
+
+My::Exporter->import( '!x' );
+
+can_ok(__PACKAGE__, qw/b/);
+ok(!__PACKAGE__->can($_), "did not import $_\()") for qw/a c x/;
+
+My::Exporter->import(qw/a c/);
+can_ok(__PACKAGE__, qw/a b c/);
+
+ok(!__PACKAGE__->can($_), "did not import $_\()") for qw/x/;
+
+My::Exporter->import();
+can_ok(__PACKAGE__, qw/a b c x/);
+
+is(__PACKAGE__->$_(), $_, "$_() eq '$_', Function is as expected") for qw/a b c x/;
+
+ok(! defined $::export, "no export scalar");
+My::Exporter->import('$export');
+is($::export, 'here', "imported export scalar");
+
+use Test::Stream::Exporter qw/export_meta/;
+my $meta = export_meta('My::Exporter');
+isa_ok($meta, 'Test::Stream::Exporter::Meta');
+is_deeply(
+ [sort $meta->default],
+ [sort qw/b x/],
+ "Got default list"
+);
+
+is_deeply(
+ [sort $meta->all],
+ [sort qw/a b c x $export/],
+ "Got all list"
+);
+
+is_deeply(
+ $meta->exports,
+ {
+ a => __PACKAGE__->can('a') || undef,
+ b => __PACKAGE__->can('b') || undef,
+ c => __PACKAGE__->can('c') || undef,
+ x => __PACKAGE__->can('x') || undef,
+
+ '$export' => \$My::Exporter::export,
+ },
+ "Exports are what we expect"
+);
+
+# Make sure export_to_level us supported
+
+BEGIN {
+ package A;
+
+ use Test::Stream::Exporter qw/import export_to_level exports/;
+ exports qw/foo/;
+
+ sub foo { 'foo' }
+
+ ###############
+ package B;
+
+ sub do_it {
+ my $class = shift;
+ my ($num) = @_;
+ $num ||= 1;
+ A->export_to_level($num, $class, 'foo');
+ }
+
+ ##############
+ package C;
+
+ sub do_it {
+ B->do_it(2);
+ }
+}
+
+{
+ package m1;
+
+ BEGIN { B->do_it }
+}
+
+{
+ package m2;
+
+ BEGIN{ C->do_it };
+}
+
+can_ok('m1', 'foo');
+can_ok('m2', 'foo');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Stream;
+use Test::MostlyLike;
+use Test::More;
+
+use ok 'Test::Stream::IOSets';
+
+my ($out, $err) = Test::Stream::IOSets->open_handles;
+ok($out && $err, "got 2 handles");
+ok(close($out), "Close stdout");
+ok(close($err), "Close stderr");
+
+my $one = Test::Stream::IOSets->new;
+isa_ok($one, 'Test::Stream::IOSets');
+mostly_like(
+ $one,
+ { ':legacy' => [], ':utf8' => undef },
+ "Legacy encoding is set",
+);
+
+ok($one->init_encoding('utf8'), "init utf8");
+
+mostly_like(
+ $one,
+ { ':legacy' => [], ':utf8' => [] },
+ "utf8 encoding is set",
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Stream;
+use Test::More;
+
+use ok 'Test::Stream::Meta';
+
+my $meta = init_tester('Some::Package');
+ok($meta, "got meta");
+isa_ok($meta, 'Test::Stream::Meta');
+can_ok($meta, qw/package encoding modern todo stream/);
+
+is(is_tester('Some::Package'), $meta, "remember the meta");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Stream;
+use Test::More;
+
+use ok 'Test::Stream::PackageUtil';
+
+can_ok(__PACKAGE__, qw/package_sym package_purge_sym/);
+
+my $ok = package_sym(__PACKAGE__, CODE => 'ok');
+is($ok, \&ok, "package sym gave us the code symbol");
+
+my $todo = package_sym(__PACKAGE__, SCALAR => 'TODO');
+is($todo, \$TODO, "got the TODO scalar");
+
+our $foo = 'foo';
+our @foo = ('f', 'o', 'o');
+our %foo = (f => 'oo');
+sub foo { 'foo' };
+
+is(foo(), 'foo', "foo() is defined");
+is($foo, 'foo', '$foo is defined');
+is_deeply(\@foo, [ 'f', 'o', 'o' ], '@foo is defined');
+is_deeply(\%foo, { f => 'oo' }, '%foo is defined');
+
+package_purge_sym(__PACKAGE__, CODE => 'foo');
+
+is($foo, 'foo', '$foo is still defined');
+is_deeply(\@foo, [ 'f', 'o', 'o' ], '@foo is still defined');
+is_deeply(\%foo, { f => 'oo' }, '%foo is still defined');
+my $r = eval { foo() };
+my $e = $@;
+ok(!$r, "Failed to call foo()");
+like($e, qr/Undefined subroutine &main::foo called/, "foo() is not defined anymore");
+ok(!__PACKAGE__->can('foo'), "can() no longer thinks we can do foo()");
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use ok 'Test::Stream::Tester::Grab';
+
+# The tests for this can be found in t/Test-Tester2.t which is the only context
+# that makes sense.
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Stream;
+use Test::More;
+
+use ok 'Test::Stream::Tester';
+
+can_ok( __PACKAGE__, 'intercept', 'events_are' );
+
+my $events = intercept {
+ ok(1, "Woo!");
+ ok(0, "Boo!");
+};
+
+isa_ok($events->[0], 'Test::Stream::Event::Ok');
+is($events->[0]->bool, 1, "Got one success");
+is($events->[0]->name, "Woo!", "Got test name");
+
+isa_ok($events->[1], 'Test::Stream::Event::Ok');
+is($events->[1]->bool, 0, "Got one fail");
+is($events->[1]->name, "Boo!", "Got test name");
+
+$events = undef;
+my $grab = grab();
+my $got = $grab ? 1 : 0;
+ok(1, "Intercepted!");
+ok(0, "Also Intercepted!");
+$events = $grab->finish;
+ok($got, "Delayed test that we did in fact get a grab object");
+is($grab, undef, "Poof! vanished!");
+is(@$events, 2, "got 2 events (2 ok)");
+events_are(
+ $events,
+ check {
+ event ok => { bool => 1 };
+ event ok => {
+ bool => 0,
+ diag => qr/Failed/,
+ };
+ dir 'end';
+ },
+ 'intercepted via grab 1'
+);
+
+$events = undef;
+$grab = grab();
+ok(1, "Intercepted!");
+ok(0, "Also Intercepted!");
+events_are(
+ $grab,
+ check {
+ event ok => { bool => 1 };
+ event ok => { bool => 0, diag => qr/Failed/ };
+ dir 'end';
+ },
+ 'intercepted via grab 2'
+);
+ok(!$grab, "Maybe it never existed?");
+
+$events = intercept {
+ ok(1, "Woo!");
+ BAIL_OUT("Ooops");
+ ok(0, "Should not see this");
+};
+is(@$events, 2, "Only got 2");
+isa_ok($events->[0], 'Test::Stream::Event::Ok');
+isa_ok($events->[1], 'Test::Stream::Event::Bail');
+
+$events = intercept {
+ plan skip_all => 'All tests are skipped';
+
+ ok(1, "Woo!");
+ BAIL_OUT("Ooops");
+ ok(0, "Should not see this");
+};
+is(@$events, 1, "Only got 1");
+isa_ok($events->[0], 'Test::Stream::Event::Plan');
+
+my $file = __FILE__;
+my $line1;
+my $line2;
+events_are(
+ intercept {
+ events_are(
+ intercept { ok(1, "foo"); $line1 = __LINE__ },
+ check {
+ $line2 = __LINE__ + 1;
+ event ok => {bool => 0};
+ dir 'end';
+ },
+ 'Lets name this test!',
+ );
+ },
+
+ check {
+ event ok => {
+ bool => 0,
+ diag => [
+ qr{Failed test 'Lets name this test!'.*at (\./)?\Q$0\E line}s,
+ qr{ Event: 'ok' from \Q$0\E line $line1}s,
+ qr{ Check: 'ok' from \Q$0\E line $line2}s,
+ qr{ \$got->\{bool\} = '1'},
+ qr{ \$exp->\{bool\} = '0'},
+ ],
+ };
+
+ dir 'end';
+ },
+ 'Failure diag checking',
+);
+
+my $line3;
+events_are(
+ intercept {
+ events_are(
+ intercept { ok(1, "foo"); ok(1, "bar"); $line3 = __LINE__ },
+ check {
+ event ok => {bool => 1};
+ dir 'end'
+ },
+ "Should Fail"
+ );
+ },
+
+ check {
+ event ok => {
+ bool => 0,
+ diag => [
+ qr/Failed test 'Should Fail'/,
+ qr/Expected end of events, got 'ok' from \Q$0\E line $line3/,
+ ],
+ };
+ },
+
+ end => 'skipping a diag',
+);
+
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Stream;
+use Test::More;
+
+use ok 'Test::Stream::Toolset';
+
+can_ok(__PACKAGE__, qw/is_tester init_tester context/);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Stream;
+use Test::More;
+use Scalar::Util qw/dualvar/;
+
+use ok 'Test::Stream::Util', qw{
+ try protect spoof is_regex is_dualvar
+};
+
+can_ok(__PACKAGE__, qw{
+ try protect spoof is_regex is_dualvar
+});
+
+my $x = dualvar( 100, 'one-hundred' );
+ok(is_dualvar($x), "Got dual var");
+$x = 1;
+ok(!is_dualvar($x), "Not dual var");
+
+$! = 100;
+
+my $ok = eval { protect { die "xxx" }; 1 };
+ok(!$ok, "protect did not capture exception");
+like($@, qr/xxx/, "expected exception");
+
+cmp_ok($!, '==', 100, "\$! did not change");
+$@ = 'foo';
+
+($ok, my $err) = try { die "xxx" };
+ok(!$ok, "cought exception");
+like( $err, qr/xxx/, "expected exception");
+is($@, 'foo', '$@ is saved');
+cmp_ok($!, '==', 100, "\$! did not change");
+
+ok(is_regex(qr/foo bar baz/), 'qr regex');
+ok(is_regex('/xxx/'), 'slash regex');
+ok(!is_regex('xxx'), 'not a regex');
+
+my ($ret, $e) = spoof ["The::Moon", "Moon.pm", 11] => "die 'xxx' . __PACKAGE__";
+ok(!$ret, "Failed eval");
+like( $e, qr/^xxxThe::Moon at Moon\.pm line 11\.?/, "Used correct package, file, and line");
+
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use ok 'Test::Tester::Capture';
+
+# This is tested in t/Legacy/TestTester
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use ok 'Test::Tester';
+
+# The tests for this can be found in t/Legacy/TestTester
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Stream;
+use Test::More;
+
+use ok 'ok';
+
+use Test::Stream::Tester;
+
+events_are (
+ intercept {
+ eval "use ok 'Something::Fake'; 1" || die $@;
+ },
+ check {
+ event ok => {
+ bool => 0,
+ name => 'use Something::Fake;',
+ diag => qr/^\s*Failed test 'use Something::Fake;'/,
+ };
+ },
+ "Basic test"
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+package MyTest;
+
+use Test::Builder;
+
+my $Test = Test::Builder->new;
+
+sub ok
+{
+ $Test->ok(@_);
+}
+
+1;
--- /dev/null
+use strict;
+use warnings;
+
+package SmallTest;
+
+require Exporter;
+
+use vars qw( @ISA @EXPORT );
+@ISA = qw( Exporter );
+@EXPORT = qw( ok is_eq is_num );
+
+use Test::Builder;
+
+my $Test = Test::Builder->new;
+
+sub ok
+{
+ $Test->ok(@_);
+}
+
+sub is_eq
+{
+ $Test->is_eq(@_);
+}
+
+sub is_num
+{
+ $Test->is_num(@_);
+}
+
+sub getTest
+{
+ return $Test;
+}
+1;
+++ /dev/null
-#!/usr/bin/perl -w
-
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = '../lib';
- }
-}
-
-use Config;
-BEGIN {
- unless ( $] >= 5.008001 && $Config{'useithreads'} &&
- eval { require threads; 'threads'->import; 1; })
- {
- print "1..0 # Skip: no working threads\n";
- exit 0;
- }
-}
-
-use strict;
-use Test::Builder;
-
-my $Test = Test::Builder->new;
-$Test->exported_to('main');
-$Test->plan(tests => 6);
-
-for(1..5) {
- 'threads'->create(sub {
- $Test->ok(1,"Each of these should app the test number")
- })->join;
-}
-
-$Test->is_num($Test->current_test(), 5,"Should be five");
+++ /dev/null
-#!/usr/bin/perl -w
-
-# Make sure all the modules have the same version
-#
-# TBT has its own version system.
-
-use strict;
-use Test::More;
-
-require Test::Builder;
-require Test::Builder::Module;
-require Test::Simple;
-
-my $dist_version = Test::More->VERSION;
-
-like( $dist_version, qr/^ \d+ \. \d+ $/x );
-
-my @modules = qw(
- Test::Simple
- Test::Builder
- Test::Builder::Module
-);
-
-for my $module (@modules) {
- is( $dist_version, $module->VERSION, $module );
-}
-
-done_testing(4);
--- /dev/null
+#!/usr/bin/perl
+
+# Test important dependant modules so we don't accidentally half of CPAN.
+
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ plan skip_all => "Dependents only tested when releasing" unless $ENV{PERL_RELEASING};
+}
+
+require File::Spec;
+use CPAN;
+
+CPAN::HandleConfig->load;
+$CPAN::Config->{test_report} = 0;
+
+# Module which depend on Test::More to test
+my @Modules = qw(
+ Test::Tester
+ Test::Most
+ Test::Warn
+ Test::Exception
+ Test::Class
+ Test::Deep
+ Test::Differences
+ Test::NoWarnings
+);
+
+# Modules which are known to be broken
+my %Broken = map { $_ => 1 } (
+ 'Test::Most',
+ 'Test::Differences'
+);
+
+# Have to do it here because CPAN chdirs.
+my $perl5lib = join ":", File::Spec->rel2abs("blib/lib"), File::Spec->rel2abs("lib");
+
+TODO: for my $name (@ARGV ? @ARGV : @Modules) {
+ local $TODO = "$name known to be broken" if $Broken{$name};
+ local $ENV{PERL5LIB} = $perl5lib;
+
+ my $module = CPAN::Shell->expand("Module", $name);
+ $module->make;
+ $module->test;
+ my $test_result = $module->distribution->{make_test};
+ ok( $test_result && !$test_result->failed, $name );
+}
+done_testing();
package experimental;
-$experimental::VERSION = '0.012';
+$experimental::VERSION = '0.013';
use strict;
use warnings;
use version ();
fc => '5.16.0',
lexical_topic => '5.10.0',
lexical_subs => '5.18.0',
- lvalue_refs => '5.21.5',
postderef => '5.20.0',
postderef_qq => '5.20.0',
+ refaliasing => '5.21.5',
regex_sets => '5.18.0',
say => '5.10.0',
smartmatch => '5.10.0',
=head1 VERSION
-version 0.012
+version 0.013
=head1 SYNOPSIS
array_base - allow the use of $[ to change the starting index of @array
autoderef - allow push, each, keys, and other built-ins on references
lexical_topic - allow the use of lexical $_ via "my $_"
- lvalue_refs - allow aliasing via \$x = \$y
postderef - allow the use of postfix dereferencing expressions, including
in interpolating strings
+ refaliasing - allow aliasing via \$x = \$y
regex_sets - allow extended bracketed character classes in regexps
signatures - allow subroutine signatures (for named arguments)
smartmatch - allow the use of ~~
}
if ($] >= 5.021005) {
- is (eval <<'END', 1, 'lvalue ref compiles') or diag $@;
+ is (eval <<'END', 1, 'ref aliasing compiles') or diag $@;
use experimental 'refaliasing';
\@a = \@b;
is(\@a, \@b, '@a and @b are the same after \@a=\@b');
#endif
#define CvFILEGV(sv) (gv_fetchfile(CvFILE(sv)))
#define CvDEPTH(sv) (*S_CvDEPTHp((const CV *)sv))
-#define CvPADLIST(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist
-#define CvOUTSIDE(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_outside
-#define CvFLAGS(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_flags
+/* For use when you only have a XPVCV*, not a real CV*.
+ Must be assert protected as in S_CvDEPTHp before use. */
+#define CvDEPTHunsafe(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_depth
+
+/* these CvPADLIST/CvRESERVED asserts can be reverted one day, once stabilized */
+#define CvPADLIST(sv) (*(assert_(!CvISXSUB((CV*)(sv))) \
+ &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_padlist)))
+/* CvPADLIST_set is not public API, it can be removed one day, once stabilized */
+#ifdef DEBUGGING
+# define CvPADLIST_set(sv, padlist) Perl_set_padlist(aTHX_ (CV*)sv, padlist)
+#else
+# define CvPADLIST_set(sv, padlist) (CvPADLIST(sv) = (padlist))
+#endif
+#define CvHSCXT(sv) *(assert_(CvISXSUB((CV*)(sv))) \
+ &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_hscxt))
+#ifdef DEBUGGING
+# if PTRSIZE == 8
+# define PoisonPADLIST(sv) \
+ (((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_padlist = (PADLIST *)UINT64_C(0xEFEFEFEFEFEFEFEF))
+# elif PTRSIZE == 4
+# define PoisonPADLIST(sv) \
+ (((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_padlist = (PADLIST *)0xEFEFEFEF)
+# else
+# error unknown pointer size
+# endif
+#else
+# define PoisonPADLIST(sv) NOOP
+#endif
+
+#define CvOUTSIDE(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_outside
#define CvOUTSIDE_SEQ(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_outside_seq
+#define CvFLAGS(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_flags
/* These two are sometimes called on non-CVs */
#define CvPROTO(sv) \
our $Debug = 0;
our $ExportLevel = 0;
our $Verbose ||= 0;
-our $VERSION = '5.71';
+our $VERSION = '5.72';
our (%Cache);
sub as_heavy {
[!]name This name only
[!]:DEFAULT All names in @EXPORT
- [!]:tag All names in $EXPORT_TAGS{tag} anonymous list
+ [!]:tag All names in $EXPORT_TAGS{tag} anonymous array
[!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
A leading ! indicates that matching names should be deleted from the
Revision history for Perl extension ExtUtils::ParseXS.
+3.26 - not released yet
+ - Support added for XS handshake API introduced in 5.21.6.
+ - backported S_croak_xs_usage optimized on threaded builds
+
3.24 - Wed Mar 5 18:20:00 CET 2014
- Native Android build fixes
- More lenient syntax for embedded TYPEMAP blocks in XS:
our $VERSION;
BEGIN {
- $VERSION = '3.25';
+ $VERSION = '3.26';
}
use ExtUtils::ParseXS::Constants $VERSION;
use ExtUtils::ParseXS::CountLines $VERSION;
#
EOF
- $self->{newXS} = "newXS";
$self->{proto} = "";
-
+ unless($self->{ProtoThisXSUB}) {
+ $self->{newXS} = "newXS_deffile";
+ $self->{file} = "";
+ }
+ else {
# Build the prototype string for the xsub
- if ($self->{ProtoThisXSUB}) {
$self->{newXS} = "newXSproto_portable";
+ $self->{file} = ", file";
if ($self->{ProtoThisXSUB} eq 2) {
# User has specified empty prototype
foreach my $xname (sort keys %{ $self->{XsubAliases} }) {
my $value = $self->{XsubAliases}{$xname};
push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
-# cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}, file$self->{proto});
+# cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
# XSANY.any_i32 = $value;
EOF
}
}
elsif (@{ $self->{Attributes} }) {
push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
-# cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto});
+# cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
# apply_attrs_string("$self->{Package}", cv, "@{ $self->{Attributes} }", 0);
EOF
}
my $value = $self->{Interfaces}{$yname};
$yname = "$self->{Package}\::$yname" unless $yname =~ /::/;
push(@{ $self->{InitFileCode} }, Q(<<"EOF"));
-# cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}, file$self->{proto});
+# cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}$self->{file}$self->{proto});
# $self->{interface_macro_set}(cv,$value);
EOF
}
}
- elsif($self->{newXS} eq 'newXS'){ # work around P5NCI's empty newXS macro
+ elsif($self->{newXS} eq 'newXS_deffile'){ # work around P5NCI's empty newXS macro
push(@{ $self->{InitFileCode} },
- " $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto});\n");
+ " $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
}
else {
push(@{ $self->{InitFileCode} },
- " (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}, file$self->{proto});\n");
+ " (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
}
} # END 'PARAGRAPH' 'while' loop
/* Making a sub named "$self->{Package}::()" allows the package */
/* to be findable via fetchmethod(), and causes */
/* overload::Overloaded("$self->{Package}") to return true. */
- (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil, file$self->{proto});
+ (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil$self->{file}$self->{proto});
MAKE_FETCHMETHOD_WORK
}
print Q(<<"EOF");
#XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */
#XS_EXTERNAL(boot_$self->{Module_cname})
-EOF
-
- print Q(<<"EOF");
#[[
+##if PERL_VERSION_LE(5, 21, 5)
# dVAR; dXSARGS;
+##else
+# dVAR; ${\($self->{WantVersionChk} ?
+ 'dXSBOOTARGSXSAPIVERCHK;' : 'dXSBOOTARGSAPIVERCHK;')}
+##endif
EOF
#Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const
print Q(<<"EOF");
# PERL_UNUSED_VAR(cv); /* -W */
# PERL_UNUSED_VAR(items); /* -W */
-##ifdef XS_APIVERSION_BOOTCHECK
+EOF
+
+ if( $self->{WantVersionChk}){
+ print Q(<<"EOF") ;
+##if PERL_VERSION_LE(5, 21, 5)
+# XS_VERSION_BOOTCHECK;
+## ifdef XS_APIVERSION_BOOTCHECK
# XS_APIVERSION_BOOTCHECK;
+## endif
##endif
+
EOF
+ } else {
+ print Q(<<"EOF") ;
+##if PERL_VERSION_LE(5, 21, 5) && defined(XS_APIVERSION_BOOTCHECK)
+# XS_APIVERSION_BOOTCHECK;
+##endif
- print Q(<<"EOF") if $self->{WantVersionChk};
-# XS_VERSION_BOOTCHECK;
-#
EOF
+ }
print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces};
# {
}
print Q(<<'EOF');
-##if (PERL_REVISION == 5 && PERL_VERSION >= 9)
-# if (PL_unitcheckav)
-# call_list(PL_scopestack_ix, PL_unitcheckav);
-##endif
-EOF
-
- print Q(<<"EOF");
+##if PERL_VERSION_LE(5, 21, 5)
+## if PERL_VERSION_GE(5, 9, 0)
+# if (PL_unitcheckav)
+# call_list(PL_scopestack_ix, PL_unitcheckav);
+## endif
# XSRETURN_YES;
+##else
+# Perl_xs_boot_epilog(aTHX_ ax);
+##endif
#]]
#
EOF
$self->{Overload} = 1 unless $self->{Overload};
my $overload = "$self->{Package}\::(".$1;
push(@{ $self->{InitFileCode} },
- " (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}, file$self->{proto});\n");
+ " (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n");
}
}
}
use warnings;
use Symbol;
-our $VERSION = '3.25';
+our $VERSION = '3.26';
=head1 NAME
package ExtUtils::ParseXS::CountLines;
use strict;
-our $VERSION = '3.25';
+our $VERSION = '3.26';
our $SECTION_END_MARKER;
use strict;
use warnings;
-our $VERSION = '3.25';
+our $VERSION = '3.26';
=head1 NAME
use lib qw( lib );
use ExtUtils::ParseXS::Constants ();
-our $VERSION = '3.25';
+our $VERSION = '3.26';
our (@ISA, @EXPORT_OK);
@ISA = qw(Exporter);
/* prototype to pass -Wmissing-prototypes */
STATIC void
-S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
+S_croak_xs_usage(const CV *const cv, const char *const params);
STATIC void
-S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
+S_croak_xs_usage(const CV *const cv, const char *const params)
{
const GV *const gv = CvGV(cv);
const char *const hvname = stash ? HvNAME(stash) : NULL;
if (hvname)
- Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
+ Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params);
else
- Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
+ Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
} else {
/* Pants. I don't think that it should be possible to get here. */
- Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
+ Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
}
}
#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
-#ifdef PERL_IMPLICIT_CONTEXT
-#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
-#else
#define croak_xs_usage S_croak_xs_usage
-#endif
#endif
#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
#endif /* !defined(newXS_flags) */
+#if PERL_VERSION_LE(5, 21, 5)
+# define newXS_deffile(a,b) Perl_newXS(aTHX_ a,b,file)
+#else
+# define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b)
+#endif
+
EOF
return 1;
}
This keyword can be used when an XSUB requires special cleanup procedures
before it terminates. When the CLEANUP: keyword is used it must follow
-any CODE:, PPCODE:, or OUTPUT: blocks which are present in the XSUB. The
-code specified for the cleanup block will be added as the last statements
-in the XSUB.
+any CODE:, or OUTPUT: blocks which are present in the XSUB. The code
+specified for the cleanup block will be added as the last statements in
+the XSUB.
=head2 The POSTCALL: Keyword
use strict;
use warnings;
$| = 1;
-use Test::More tests => 5;
+use Test::More tests => 4;
use File::Spec;
use lib (-d 't' ? File::Spec->catdir(qw(t lib)) : 'lib');
use ExtUtils::ParseXS::Utilities qw(
my @statements = (
'#ifndef PERL_UNUSED_VAR',
'#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE',
- '#ifdef PERL_IMPLICIT_CONTEXT',
'#ifdef newXS_flags',
);
@ISA = qw(IO::Handle);
-$VERSION = "1.37";
+$VERSION = "1.38";
@EXPORT_OK = qw(sockatmark);
=item connected
-If the socket is in a connected state the peer address is returned.
-If the socket is not in a connected state then undef will be returned.
+If the socket is in a connected state, the peer address is returned. If the
+socket is not in a connected state, undef is returned.
+
+Note that connected() considers a half-open TCP socket to be "in a connected
+state". Specifically, connected() does not distinguish between the
+B<ESTABLISHED> and B<CLOSE-WAIT> TCP states; it returns the peer address,
+rather than undef, in either case. Thus, in general, connected() cannot
+be used to reliably learn whether the peer has initiated a graceful shutdown
+because in most cases (see below) the local TCP state machine remains in
+B<CLOSE-WAIT> until the local application calls shutdown() or close();
+only at that point does connected() return undef.
+
+The "in most cases" hedge is because local TCP state machine behavior may
+depend on the peer's socket options. In particular, if the peer socket has
+SO_LINGER enabled with a zero timeout, then the peer's close() will generate
+a RST segment, upon receipt of which the local TCP transitions immediately to
+B<CLOSED>, and in that state, connected() I<will> return undef.
=item protocol
+5.20141120
+ - Updated for v5.21.6
+
5.20141020
- - Prepared for v5.21.5
+ - Updated for v5.21.5
5.20141002
- Updated for v5.18.3 and v5.18.4
%bug_tracker %deprecated %delta/;
use Module::CoreList::TieHashDelta;
use version;
-$VERSION = '5.20141020';
+$VERSION = '5.20141120';
my $dumpinc = 0;
sub import {
5.020001 => '2014-09-14',
5.021004 => '2014-09-20',
5.021005 => '2014-10-20',
+ 5.021006 => '2014-11-20',
);
for my $version ( sort { $a <=> $b } keys %released ) {
removed => {
}
},
+ 5.021006 => {
+ delta_from => 5.021005,
+ changed => {
+ 'App::Prove' => '3.34',
+ 'App::Prove::State' => '3.34',
+ 'App::Prove::State::Result'=> '3.34',
+ 'App::Prove::State::Result::Test'=> '3.34',
+ 'B' => '1.53',
+ 'B::Concise' => '0.995',
+ 'B::Deparse' => '1.30',
+ 'B::Op_private' => '5.021006',
+ 'CPAN::Meta' => '2.143240',
+ 'CPAN::Meta::Converter' => '2.143240',
+ 'CPAN::Meta::Feature' => '2.143240',
+ 'CPAN::Meta::History' => '2.143240',
+ 'CPAN::Meta::Merge' => '2.143240',
+ 'CPAN::Meta::Prereqs' => '2.143240',
+ 'CPAN::Meta::Requirements'=> '2.130',
+ 'CPAN::Meta::Spec' => '2.143240',
+ 'CPAN::Meta::Validator' => '2.143240',
+ 'Config' => '5.021006',
+ 'Devel::Peek' => '1.19',
+ 'Digest::SHA' => '5.93',
+ 'DynaLoader' => '1.28',
+ 'Encode' => '2.64',
+ 'Exporter' => '5.72',
+ 'Exporter::Heavy' => '5.72',
+ 'ExtUtils::Command::MM' => '7.02',
+ 'ExtUtils::Liblist' => '7.02',
+ 'ExtUtils::Liblist::Kid'=> '7.02',
+ 'ExtUtils::MM' => '7.02',
+ 'ExtUtils::MM_AIX' => '7.02',
+ 'ExtUtils::MM_Any' => '7.02',
+ 'ExtUtils::MM_BeOS' => '7.02',
+ 'ExtUtils::MM_Cygwin' => '7.02',
+ 'ExtUtils::MM_DOS' => '7.02',
+ 'ExtUtils::MM_Darwin' => '7.02',
+ 'ExtUtils::MM_MacOS' => '7.02',
+ 'ExtUtils::MM_NW5' => '7.02',
+ 'ExtUtils::MM_OS2' => '7.02',
+ 'ExtUtils::MM_QNX' => '7.02',
+ 'ExtUtils::MM_UWIN' => '7.02',
+ 'ExtUtils::MM_Unix' => '7.02',
+ 'ExtUtils::MM_VMS' => '7.02',
+ 'ExtUtils::MM_VOS' => '7.02',
+ 'ExtUtils::MM_Win32' => '7.02',
+ 'ExtUtils::MM_Win95' => '7.02',
+ 'ExtUtils::MY' => '7.02',
+ 'ExtUtils::MakeMaker' => '7.02',
+ 'ExtUtils::MakeMaker::Config'=> '7.02',
+ 'ExtUtils::MakeMaker::Locale'=> '7.02',
+ 'ExtUtils::MakeMaker::version'=> '7.02',
+ 'ExtUtils::MakeMaker::version::regex'=> '7.02',
+ 'ExtUtils::MakeMaker::version::vpp'=> '7.02',
+ 'ExtUtils::Manifest' => '1.69',
+ 'ExtUtils::Mkbootstrap' => '7.02',
+ 'ExtUtils::Mksymlists' => '7.02',
+ 'ExtUtils::ParseXS' => '3.26',
+ 'ExtUtils::ParseXS::Constants'=> '3.26',
+ 'ExtUtils::ParseXS::CountLines'=> '3.26',
+ 'ExtUtils::ParseXS::Eval'=> '3.26',
+ 'ExtUtils::ParseXS::Utilities'=> '3.26',
+ 'ExtUtils::testlib' => '7.02',
+ 'File::Spec::VMS' => '3.52',
+ 'HTTP::Tiny' => '0.051',
+ 'I18N::Langinfo' => '0.12',
+ 'IO::Socket' => '1.38',
+ 'Module::CoreList' => '5.20141120',
+ 'Module::CoreList::TieHashDelta'=> '5.20141120',
+ 'Module::CoreList::Utils'=> '5.20141120',
+ 'POSIX' => '1.46',
+ 'PerlIO::encoding' => '0.20',
+ 'PerlIO::scalar' => '0.20',
+ 'TAP::Base' => '3.34',
+ 'TAP::Formatter::Base' => '3.34',
+ 'TAP::Formatter::Color' => '3.34',
+ 'TAP::Formatter::Console'=> '3.34',
+ 'TAP::Formatter::Console::ParallelSession'=> '3.34',
+ 'TAP::Formatter::Console::Session'=> '3.34',
+ 'TAP::Formatter::File' => '3.34',
+ 'TAP::Formatter::File::Session'=> '3.34',
+ 'TAP::Formatter::Session'=> '3.34',
+ 'TAP::Harness' => '3.34',
+ 'TAP::Harness::Env' => '3.34',
+ 'TAP::Object' => '3.34',
+ 'TAP::Parser' => '3.34',
+ 'TAP::Parser::Aggregator'=> '3.34',
+ 'TAP::Parser::Grammar' => '3.34',
+ 'TAP::Parser::Iterator' => '3.34',
+ 'TAP::Parser::Iterator::Array'=> '3.34',
+ 'TAP::Parser::Iterator::Process'=> '3.34',
+ 'TAP::Parser::Iterator::Stream'=> '3.34',
+ 'TAP::Parser::IteratorFactory'=> '3.34',
+ 'TAP::Parser::Multiplexer'=> '3.34',
+ 'TAP::Parser::Result' => '3.34',
+ 'TAP::Parser::Result::Bailout'=> '3.34',
+ 'TAP::Parser::Result::Comment'=> '3.34',
+ 'TAP::Parser::Result::Plan'=> '3.34',
+ 'TAP::Parser::Result::Pragma'=> '3.34',
+ 'TAP::Parser::Result::Test'=> '3.34',
+ 'TAP::Parser::Result::Unknown'=> '3.34',
+ 'TAP::Parser::Result::Version'=> '3.34',
+ 'TAP::Parser::Result::YAML'=> '3.34',
+ 'TAP::Parser::ResultFactory'=> '3.34',
+ 'TAP::Parser::Scheduler'=> '3.34',
+ 'TAP::Parser::Scheduler::Job'=> '3.34',
+ 'TAP::Parser::Scheduler::Spinner'=> '3.34',
+ 'TAP::Parser::Source' => '3.34',
+ 'TAP::Parser::SourceHandler'=> '3.34',
+ 'TAP::Parser::SourceHandler::Executable'=> '3.34',
+ 'TAP::Parser::SourceHandler::File'=> '3.34',
+ 'TAP::Parser::SourceHandler::Handle'=> '3.34',
+ 'TAP::Parser::SourceHandler::Perl'=> '3.34',
+ 'TAP::Parser::SourceHandler::RawTAP'=> '3.34',
+ 'TAP::Parser::YAMLish::Reader'=> '3.34',
+ 'TAP::Parser::YAMLish::Writer'=> '3.34',
+ 'Test::Builder' => '1.301001_075',
+ 'Test::Builder::Module' => '1.301001_075',
+ 'Test::Builder::Tester' => '1.301001_075',
+ 'Test::Builder::Tester::Color'=> '1.301001_075',
+ 'Test::Harness' => '3.34',
+ 'Test::More' => '1.301001_075',
+ 'Test::More::DeepCheck' => undef,
+ 'Test::More::DeepCheck::Strict'=> undef,
+ 'Test::More::DeepCheck::Tolerant'=> undef,
+ 'Test::More::Tools' => undef,
+ 'Test::MostlyLike' => undef,
+ 'Test::Simple' => '1.301001_075',
+ 'Test::Stream' => '1.301001_075',
+ 'Test::Stream::ArrayBase'=> undef,
+ 'Test::Stream::ArrayBase::Meta'=> undef,
+ 'Test::Stream::Carp' => undef,
+ 'Test::Stream::Context' => undef,
+ 'Test::Stream::Event' => undef,
+ 'Test::Stream::Event::Bail'=> undef,
+ 'Test::Stream::Event::Child'=> undef,
+ 'Test::Stream::Event::Diag'=> undef,
+ 'Test::Stream::Event::Finish'=> undef,
+ 'Test::Stream::Event::Note'=> undef,
+ 'Test::Stream::Event::Ok'=> undef,
+ 'Test::Stream::Event::Plan'=> undef,
+ 'Test::Stream::Event::Subtest'=> undef,
+ 'Test::Stream::ExitMagic'=> undef,
+ 'Test::Stream::ExitMagic::Context'=> undef,
+ 'Test::Stream::Exporter'=> undef,
+ 'Test::Stream::Exporter::Meta'=> undef,
+ 'Test::Stream::IOSets' => undef,
+ 'Test::Stream::Meta' => undef,
+ 'Test::Stream::PackageUtil'=> undef,
+ 'Test::Stream::Tester' => undef,
+ 'Test::Stream::Tester::Checks'=> undef,
+ 'Test::Stream::Tester::Checks::Event'=> undef,
+ 'Test::Stream::Tester::Events'=> undef,
+ 'Test::Stream::Tester::Events::Event'=> undef,
+ 'Test::Stream::Tester::Grab'=> undef,
+ 'Test::Stream::Threads' => undef,
+ 'Test::Stream::Toolset' => undef,
+ 'Test::Stream::Util' => undef,
+ 'Test::Tester' => '1.301001_075',
+ 'Test::Tester::Capture' => undef,
+ 'Test::use::ok' => '1.301001_075',
+ 'Unicode::UCD' => '0.59',
+ 'XS::APItest' => '0.68',
+ 'XSLoader' => '0.19',
+ 'experimental' => '0.013',
+ 'locale' => '1.05',
+ 'ok' => '1.301001_075',
+ 'overload' => '1.24',
+ 're' => '0.28',
+ 'warnings' => '1.29',
+ },
+ removed => {
+ }
+ },
);
sub is_core
removed => {
}
},
+ 5.021006 => {
+ delta_from => 5.021005,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
for my $version (sort { $a <=> $b } keys %deprecated) {
'ExtUtils::MY' => 'cpan',
'ExtUtils::MakeMaker' => 'cpan',
'ExtUtils::MakeMaker::Config'=> 'cpan',
+ 'ExtUtils::MakeMaker::Locale'=> 'cpan',
+ 'ExtUtils::MakeMaker::version'=> 'cpan',
+ 'ExtUtils::MakeMaker::version::regex'=> 'cpan',
+ 'ExtUtils::MakeMaker::version::vpp'=> 'cpan',
'ExtUtils::Manifest' => 'cpan',
'ExtUtils::Mkbootstrap' => 'cpan',
'ExtUtils::Mksymlists' => 'cpan',
'Test::Builder::Tester::Color'=> 'cpan',
'Test::Harness' => 'cpan',
'Test::More' => 'cpan',
+ 'Test::More::DeepCheck' => 'cpan',
+ 'Test::More::DeepCheck::Strict'=> 'cpan',
+ 'Test::More::DeepCheck::Tolerant'=> 'cpan',
+ 'Test::More::Tools' => 'cpan',
+ 'Test::MostlyLike' => 'cpan',
'Test::Simple' => 'cpan',
+ 'Test::Stream' => 'cpan',
+ 'Test::Stream::ArrayBase'=> 'cpan',
+ 'Test::Stream::ArrayBase::Meta'=> 'cpan',
+ 'Test::Stream::Carp' => 'cpan',
+ 'Test::Stream::Context' => 'cpan',
+ 'Test::Stream::Event' => 'cpan',
+ 'Test::Stream::Event::Bail'=> 'cpan',
+ 'Test::Stream::Event::Child'=> 'cpan',
+ 'Test::Stream::Event::Diag'=> 'cpan',
+ 'Test::Stream::Event::Finish'=> 'cpan',
+ 'Test::Stream::Event::Note'=> 'cpan',
+ 'Test::Stream::Event::Ok'=> 'cpan',
+ 'Test::Stream::Event::Plan'=> 'cpan',
+ 'Test::Stream::Event::Subtest'=> 'cpan',
+ 'Test::Stream::ExitMagic'=> 'cpan',
+ 'Test::Stream::ExitMagic::Context'=> 'cpan',
+ 'Test::Stream::Exporter'=> 'cpan',
+ 'Test::Stream::Exporter::Meta'=> 'cpan',
+ 'Test::Stream::IOSets' => 'cpan',
+ 'Test::Stream::Meta' => 'cpan',
+ 'Test::Stream::PackageUtil'=> 'cpan',
+ 'Test::Stream::Tester' => 'cpan',
+ 'Test::Stream::Tester::Checks'=> 'cpan',
+ 'Test::Stream::Tester::Checks::Event'=> 'cpan',
+ 'Test::Stream::Tester::Events'=> 'cpan',
+ 'Test::Stream::Tester::Events::Event'=> 'cpan',
+ 'Test::Stream::Tester::Grab'=> 'cpan',
+ 'Test::Stream::Threads' => 'cpan',
+ 'Test::Stream::Toolset' => 'cpan',
+ 'Test::Stream::Util' => 'cpan',
+ 'Test::Tester' => 'cpan',
+ 'Test::Tester::Capture' => 'cpan',
+ 'Test::use::ok' => 'cpan',
'Text::Balanced' => 'cpan',
'Text::ParseWords' => 'cpan',
'Text::Tabs' => 'cpan',
'encoding' => 'cpan',
'encoding::warnings' => 'cpan',
'experimental' => 'cpan',
+ 'ok' => 'cpan',
'parent' => 'cpan',
'perlfaq' => 'cpan',
'version' => 'cpan',
'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::MakeMaker::Locale'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker',
+ 'ExtUtils::MakeMaker::version'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker',
+ 'ExtUtils::MakeMaker::version::regex'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker',
+ 'ExtUtils::MakeMaker::version::vpp'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker',
'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',
'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::More::DeepCheck' => undef,
+ 'Test::More::DeepCheck::Strict'=> undef,
+ 'Test::More::DeepCheck::Tolerant'=> undef,
+ 'Test::More::Tools' => undef,
+ 'Test::MostlyLike' => undef,
'Test::Simple' => 'http://github.com/Test-More/test-more/issues/',
+ 'Test::Stream' => undef,
+ 'Test::Stream::ArrayBase'=> undef,
+ 'Test::Stream::ArrayBase::Meta'=> undef,
+ 'Test::Stream::Carp' => undef,
+ 'Test::Stream::Context' => undef,
+ 'Test::Stream::Event' => undef,
+ 'Test::Stream::Event::Bail'=> undef,
+ 'Test::Stream::Event::Child'=> undef,
+ 'Test::Stream::Event::Diag'=> undef,
+ 'Test::Stream::Event::Finish'=> undef,
+ 'Test::Stream::Event::Note'=> undef,
+ 'Test::Stream::Event::Ok'=> undef,
+ 'Test::Stream::Event::Plan'=> undef,
+ 'Test::Stream::Event::Subtest'=> undef,
+ 'Test::Stream::ExitMagic'=> undef,
+ 'Test::Stream::ExitMagic::Context'=> undef,
+ 'Test::Stream::Exporter'=> undef,
+ 'Test::Stream::Exporter::Meta'=> undef,
+ 'Test::Stream::IOSets' => undef,
+ 'Test::Stream::Meta' => undef,
+ 'Test::Stream::PackageUtil'=> undef,
+ 'Test::Stream::Tester' => undef,
+ 'Test::Stream::Tester::Checks'=> undef,
+ 'Test::Stream::Tester::Checks::Event'=> undef,
+ 'Test::Stream::Tester::Events'=> undef,
+ 'Test::Stream::Tester::Events::Event'=> undef,
+ 'Test::Stream::Tester::Grab'=> undef,
+ 'Test::Stream::Threads' => undef,
+ 'Test::Stream::Toolset' => undef,
+ 'Test::Stream::Util' => undef,
+ 'Test::Tester' => undef,
+ 'Test::Tester::Capture' => undef,
+ 'Test::use::ok' => undef,
'Text::Balanced' => undef,
'Text::ParseWords' => undef,
'Text::Tabs' => undef,
'encoding' => undef,
'encoding::warnings' => undef,
'experimental' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=experimental',
+ 'ok' => undef,
'parent' => undef,
'perlfaq' => 'https://github.com/perl-doc-cats/perlfaq/issues',
'version' => undef,
use strict;
use vars qw($VERSION);
-$VERSION = '5.20141020';
+$VERSION = '5.20141120';
sub TIEHASH {
my ($class, $changed, $removed, $parent) = @_;
use Module::CoreList;
use Module::CoreList::TieHashDelta;
-$VERSION = '5.20141020';
+$VERSION = '5.20141120';
sub utilities {
my $perl = shift;
removed => {
}
},
+ 5.021006 => {
+ delta_from => 5.021005,
+ changed => {
+ },
+ removed => {
+ }
+ },
);
for my $version (sort { $a <=> $b } keys %delta) {
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.51';
+$VERSION = '3.52';
$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
# Only passed a single file?
my $xfile = (defined($file) && length($file)) ? $file : '';
- $rslt = $unix_rpt ? $file : vmsify($file);
+ $rslt = $unix_rpt ? $xfile : vmsify($xfile);
}
return $self->canonpath($rslt) unless $unix_rpt;
sub abs2rel {
my $self = shift;
return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
- if grep m{/}, @_;
+ if ((grep m{/}, @_) && !(grep m{(?<!\^)[\[<:]}, @_));
my($path,$base) = @_;
$base = $self->_cwd() unless defined $base and length $base;
- for ($path, $base) { $_ = $self->canonpath($_) }
+ # If there is no device or directory syntax on $base, make sure it
+ # is treated as a directory.
+ $base = VMS::Filespec::vmspath($base) unless $base =~ m{(?<!\^)[\[<:]};
+
+ for ($path, $base) { $_ = $self->rel2abs($_) }
# Are we even starting $path on the same (node::)device as $base? Note that
# logical paths or nodename differences may be on the "same device"
my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
return $path unless lc($path_volume) eq lc($base_volume);
- for ($path, $base) { $_ = $self->rel2abs($_) }
-
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_directories );
my $pathchunks = @pathchunks;
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+
+use Cwd qw(cwd getcwd abs_path);
+use File::Spec();
+use File::Temp qw(tempdir);
+use File::Path qw(make_path);
+
+my $startdir = cwd();
+my @files = ( 'anyfile', './anyfile', '../first_sub_dir/anyfile', '../second_sub_dir/second_file' );
+
+for my $file (@files) {
+ test_rel2abs($file);
+}
+
+sub test_rel2abs {
+ my $first_file = shift;
+ my $tdir = tempdir( CLEANUP => 1 );
+ chdir $tdir or die "Unable to change to $tdir: $!";
+
+ my @subdirs = (
+ 'first_sub_dir',
+ File::Spec->catdir('first_sub_dir', 'sub_sub_dir'),
+ 'second_sub_dir'
+ );
+ make_path(@subdirs, { mode => 0711 })
+ or die "Unable to make_path: $!";
+
+ open my $OUT2, '>',
+ File::Spec->catfile('second_sub_dir', 'second_file')
+ or die "Unable to open 'second_file' for writing: $!";
+ print $OUT2 "Attempting to resolve RT #121360\n";
+ close $OUT2 or die "Unable to close 'second_file' after writing: $!";
+
+ chdir 'first_sub_dir'
+ or die "Unable to change to 'first_sub_dir': $!";
+ open my $OUT1, '>', $first_file
+ or die "Unable to open $first_file for writing: $!";
+ print $OUT1 "Attempting to resolve RT #121360\n";
+ close $OUT1 or die "Unable to close $first_file after writing: $!";
+
+ my $rel_path = $first_file;
+ my $rel_base = File::Spec->catdir(File::Spec->curdir(), 'sub_sub_dir');
+ my $abs_path = File::Spec->rel2abs($rel_path);
+ my $abs_base = File::Spec->rel2abs($rel_base);
+ ok(-f $rel_path, "'$rel_path' is readable by effective uid/gid");
+ ok(-f $abs_path, "'$abs_path' is readable by effective uid/gid");
+ is_deeply(
+ [ (stat $rel_path)[0..5] ],
+ [ (stat $abs_path)[0..5] ],
+ "rel_path and abs_path stat same"
+ );
+ ok(-d $rel_base, "'$rel_base' is a directory");
+ ok(-d $abs_base, "'$abs_base' is a directory");
+ is_deeply(
+ [ (stat $rel_base)[0..5] ],
+ [ (stat $abs_base)[0..5] ],
+ "rel_base and abs_base stat same"
+ );
+ my $rr_link = File::Spec->abs2rel($rel_path, $rel_base);
+ my $ra_link = File::Spec->abs2rel($rel_path, $abs_base);
+ my $ar_link = File::Spec->abs2rel($abs_path, $rel_base);
+ my $aa_link = File::Spec->abs2rel($abs_path, $abs_base);
+ is($rr_link, $ra_link,
+ "rel_path-rel_base '$rr_link' = rel_path-abs_base '$ra_link'");
+ is($ar_link, $aa_link,
+ "abs_path-rel_base '$ar_link' = abs_path-abs_base '$aa_link'");
+ is($rr_link, $aa_link,
+ "rel_path-rel_base '$rr_link' = abs_path-abs_base '$aa_link'");
+
+ chdir $startdir or die "Unable to change back to $startdir: $!";
+}
+
+done_testing();
package XSLoader;
-$VERSION = "0.18";
+$VERSION = "0.19";
#use strict;
EOT
-print OUT <<'EOT' if defined &DynaLoader::mod2fname;
+# defined &DynaLoader::mod2fname catches most cases, except when
+# cross-compiling to a system that defines mod2fname. Using
+# $Config{d_libname_unique} is a best attempt at catching those cases.
+print OUT <<'EOT' if defined &DynaLoader::mod2fname || $Config{d_libname_unique};
# Some systems have restrictions on files names for DLL's etc.
# mod2fname returns appropriate file base name (typically truncated)
# It may also edit @modparts if required.
- $modfname = &mod2fname(\@modparts) if defined &mod2fname;
+ $modfname = &DynaLoader::mod2fname(\@modparts) if defined &DynaLoader::mod2fname;
EOT
}
END {
+ # rmtree() can indirectly load the XS object for Win32, ensure
+ # we have our original sane @INC
+ local @INC = @OrigINC;
# cleanup the auto/ directory we created.
rmtree([$lib_dir[0]]);
}
*s = 'w';
if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) {
PerlIO_close(fp);
- IoIFP(io) = NULL;
goto say_false;
}
}
if (!PL_argvoutgv)
PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
- if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) {
+ if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) {
IoFLAGS(io) &= ~IOf_START;
if (PL_inplace) {
assert(PL_defoutgv);
}
return FALSE;
}
- retval = io_close(io, not_implicit);
+ retval = io_close(io, NULL, not_implicit, FALSE);
if (not_implicit) {
IoLINES(io) = 0;
IoPAGE(io) = 0;
}
bool
-Perl_io_close(pTHX_ IO *io, bool not_implicit)
+Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
{
bool retval = FALSE;
else {
if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
const bool prev_err = PerlIO_error(IoOFP(io));
+#ifdef USE_PERLIO
+ if (prev_err)
+ PerlIO_restore_errno(IoOFP(io));
+#endif
retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err);
PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
}
else {
const bool prev_err = PerlIO_error(IoIFP(io));
+#ifdef USE_PERLIO
+ if (prev_err)
+ PerlIO_restore_errno(IoIFP(io));
+#endif
retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err);
}
}
IoOFP(io) = IoIFP(io) = NULL;
+
+ if (warn_on_fail && !retval) {
+ if (gv)
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
+ "Warning: unable to close filehandle %"
+ HEKf" properly: %"SVf,
+ GvNAME_HEK(gv), get_sv("!",GV_ADD));
+ else
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
+ "Warning: unable to close filehandle "
+ "properly: %"SVf,
+ get_sv("!",GV_ADD));
+ }
}
else if (not_implicit) {
SETERRNO(EBADF,SS_IVCHAN);
#endif
}
else {
+ SETERRNO(EBADF,RMS_IFI);
tot--;
}
}
#endif
}
else {
+ SETERRNO(EBADF,RMS_IFI);
tot--;
}
}
I32 items = sp - mark;
STRLEN len;
STRLEN delimlen;
+ const char * const delims = SvPV_const(delim, delimlen);
PERL_ARGS_ASSERT_DO_JOIN;
- (void) SvPV_const(delim, delimlen); /* stringify and get the delimlen */
- /* SvCUR assumes it's SvPOK() and woe betide you if it's not. */
-
mark++;
len = (items > 0 ? (delimlen * (items - 1) ) : 0);
SvUPGRADE(sv, SVt_PV);
}
if (delimlen) {
+ const U32 delimflag = DO_UTF8(delim) ? SV_CATUTF8 : SV_CATBYTES;
for (; items > 0; items--,mark++) {
STRLEN len;
const char *s;
- sv_catsv_nomg(sv,delim);
+ sv_catpvn_flags(sv,delims,delimlen,delimflag);
s = SvPV_const(*mark,len);
sv_catpvn_flags(sv,s,len,
DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES);
"Character following \"\\c\" must be printable ASCII");
}
else if (source == '{') {
- assert(isPRINT_A(toCTRL('{')));
-
- /* diag_listed_as: Use "%s" instead of "%s" */
- Perl_croak(aTHX_ "Use \"%c\" instead of \"\\c{\"", toCTRL('{'));
+ const char control = toCTRL('{');
+ if (isPRINT_A(control)) {
+ /* diag_listed_as: Use "%s" instead of "%s" */
+ Perl_croak(aTHX_ "Use \"%c\" instead of \"\\c{\"", control);
+ }
+ else {
+ Perl_croak(aTHX_ "Sequence \"\\c{\" invalid");
+ }
}
result = toCTRL(source);
Escapes at most the first "count" chars of pv and puts the results into
dsv such that the size of the escaped string will not exceed "max" chars
-and will not contain any incomplete escape sequences. The number of bytes
+and will not contain any incomplete escape sequences. The number of bytes
escaped will be returned in the STRLEN *escaped parameter if it is not null.
When the dsv parameter is null no escaping actually occurs, but the number
of bytes that would be escaped were it not null will be calculated.
if (o->op_targ) {
if (optype == OP_NULL) {
Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
- if (o->op_targ == OP_NEXTSTATE) {
- if (CopLINE(cCOPo))
- Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
- (UV)CopLINE(cCOPo));
- if (CopSTASHPV(cCOPo)) {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
- HV *stash = CopSTASH(cCOPo);
- const char * const hvname = HvNAME_get(stash);
-
- Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
- generic_pv_escape( tmpsv, hvname, HvNAMELEN(stash), HvNAMEUTF8(stash)));
- }
- if (CopLABEL(cCOPo)) {
- SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
- STRLEN label_len;
- U32 label_flags;
- const char *label = CopLABEL_len_flags(cCOPo,
- &label_len,
- &label_flags);
- Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
- generic_pv_escape( tmpsv, label, label_len,(label_flags & SVf_UTF8)));
- }
-
- }
}
else
Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
#endif
break;
+ case OP_NULL:
+ if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
+ break;
+ /* FALLTHROUGH */
case OP_NEXTSTATE:
case OP_DBSTATE:
if (CopLINE(cCOPo))
generic_pv_escape( tmpsv, label, label_len,
(label_flags & SVf_UTF8)));
}
+ Perl_dump_indent(aTHX_ level, file, "SEQ = %d\n",
+ cCOPo->cop_seq);
break;
case OP_ENTERLOOP:
Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
- Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
- if (nest < maxnest) {
- do_dump_pad(level+1, file, CvPADLIST(sv), 0);
+ if (!CvISXSUB(sv)) {
+ Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
+ if (nest < maxnest) {
+ do_dump_pad(level+1, file, CvPADLIST(sv), 0);
+ }
}
+ else
+ Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
{
const CV * const outside = CvOUTSIDE(sv);
Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
: Used in perly.y
pR |OP* |bind_match |I32 type|NN OP *left|NN OP *right
: Used in perly.y
-pR |OP* |block_end |I32 floor|NULLOK OP* seq
+ApdR |OP* |block_end |I32 floor|NULLOK OP* seq
ApR |I32 |block_gimme
: Used in perly.y
-pR |int |block_start |int full
+ApdR |int |block_start |int full
Aodp |void |blockhook_register |NN BHK *hk
: Used in perl.c
p |void |boot_core_UNIVERSAL
p |const COP*|closest_cop |NN const COP *cop|NULLOK const OP *o \
|NULLOK const OP *curop|bool opnext
: Used in perly.y
-pR |OP* |convert |I32 optype|I32 flags|NULLOK OP* o
+ApdR |OP* |op_convert_list |I32 optype|I32 flags|NULLOK OP* o
: Used in op.c and perl.c
pM |PERL_CONTEXT* |create_eval_scope|U32 flags
Aprd |void |croak_sv |NN SV *baseex
|NN const char *const params
npr |void |croak_no_mem
nprX |void |croak_popstack
+fnprx |void |noperl_die|NN const char* pat|...
#if defined(WIN32)
norx |void |win32_croak_not_implemented|NN const char * fname
#endif
#if defined(PERL_IMPLICIT_CONTEXT)
Afnrp |void |croak_nocontext|NULLOK const char* pat|...
-:removing noreturn to silence a warning
-#ifdef _MSC_VER
-Afnp |OP* |die_nocontext |NULLOK const char* pat|...
-#else
Afnrp |OP* |die_nocontext |NULLOK const char* pat|...
-#endif
Afnp |void |deb_nocontext |NN const char* pat|...
Afnp |char* |form_nocontext |NN const char* pat|...
Anp |void |load_module_nocontext|U32 flags|NN SV* name|NULLOK SV* ver|...
ApdR |SV* |gv_const_sv |NN GV* gv
ApdRn |SV* |cv_const_sv |NULLOK const CV *const cv
pRn |SV* |cv_const_sv_or_av|NULLOK const CV *const cv
-: Used in pad.c
-pR |SV* |op_const_sv |NULLOK const OP* o|NULLOK CV* cv
Apd |SV * |cv_name |NN CV *cv|NULLOK SV *sv|U32 flags
Apd |void |cv_undef |NN CV* cv
p |void |cv_undef_flags |NN CV* cv|U32 flags
|NN const char* fromend|int delim|NN I32* retlen
: Used in op.c, perl.c
pM |void |delete_eval_scope
-:removing noreturn to silence a warning
-#ifdef _MSC_VER
-Apd |OP* |die_sv |NN SV *baseex
-Afpd |OP* |die |NULLOK const char* pat|...
-#else
Aprd |OP* |die_sv |NN SV *baseex
Afrpd |OP* |die |NULLOK const char* pat|...
-#endif
: Used in util.c
pr |void |die_unwind |NN SV* msv
Ap |void |dounwind |I32 cxix
: Used in perly.y
AnpPR |char* |instr |NN const char* big|NN const char* little
: Used in sv.c
-p |bool |io_close |NN IO* io|bool not_implicit
+p |bool |io_close |NN IO* io|NULLOK GV *gv \
+ |bool not_implicit|bool warn_on_fail
: Used in perly.y
pR |OP* |invert |NULLOK OP* cmd
ApR |I32 |is_lvalue_sub
p |U32 |magic_regdata_cnt|NN SV* sv|NN MAGIC* mg
p |int |magic_regdatum_get|NN SV* sv|NN MAGIC* mg
:removing noreturn to silence a warning for this function resulted in no
-:change to the interpreter DLL image under VS 2003 -O1 -GL 32 bits
+:change to the interpreter DLL image under VS 2003 -O1 -GL 32 bits only because
+:this is used in a magic vtable, do not use this on conventionally called funcs
#ifdef _MSC_VER
p |int |magic_regdatum_set|NN SV* sv|NN MAGIC* mg
#else
|NULLOK OP* block
p |CV * |newXS_len_flags|NULLOK const char *name|STRLEN len \
|NN XSUBADDR_t subaddr\
- |NN const char *const filename \
+ |NULLOK const char *const filename \
|NULLOK const char *const proto \
|NULLOK SV **const_svp|U32 flags
+pX |CV * |newXS_deffile |NN const char *name|NN XSUBADDR_t subaddr
ApM |CV * |newXS_flags |NULLOK const char *name|NN XSUBADDR_t subaddr\
|NN const char *const filename \
|NULLOK const char *const proto|U32 flags
Apda |SV* |newSV |const STRLEN len
Apa |OP* |newSVREF |NN OP* o
Apda |OP* |newSVOP |I32 type|I32 flags|NN SV* sv
+ApdR |OP* |newDEFSVOP
pa |SV* |newSVavdefelem |NN AV *av|SSize_t ix|bool extendible
Apda |SV* |newSViv |const IV i
Apda |SV* |newSVuv |const UV u
: FIXME - is anything in re using this now?
EXp |SV*|reg_qr_package|NN REGEXP * const rx
-: FIXME - why the E?
Anp |void |repeatcpy |NN char* to|NN const char* from|I32 len|IV count
AnpP |char* |rninstr |NN const char* big|NN const char* bigend \
|NN const char* little|NN const char* lend
Ap |char* |scan_num |NN const char* s|NN YYSTYPE *lvalp
Apd |NV |scan_oct |NN const char* start|STRLEN len|NN STRLEN* retlen
AMpd |OP* |op_scope |NULLOK OP* o
-:removing noreturn to silence a warning
-#ifdef _MSC_VER
-Ap |char* |screaminstr |NN SV *bigstr|NN SV *littlestr|I32 start_shift \
- |I32 end_shift|NN I32 *old_posp|I32 last
-#else
-Apr |char* |screaminstr |NN SV *bigstr|NN SV *littlestr|I32 start_shift \
- |I32 end_shift|NN I32 *old_posp|I32 last
-#endif
: Only used by perl.c/miniperl.c, but defined in caretx.c
px |void |set_caret_X
Apd |void |setdefout |NN GV* gv
s |void |cop_free |NN COP *cop
s |OP* |modkids |NULLOK OP *o|I32 type
s |OP* |scalarboolean |NN OP *o
-sR |OP* |newDEFSVOP
sR |OP* |search_const |NN OP *o
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
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
#endif
#if defined(PERL_IN_PP_C)
-s |void |do_chomp |NN SV *retval|NN SV *sv|bool chomping
+s |size_t |do_chomp |NN SV *retval|NN SV *sv|bool chomping
s |OP* |do_delete_local
sR |SV* |refto |NN SV* sv
#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
+sRM |UV |check_locale_boundary_crossing \
+ |NN const char * const func_name \
+ |NN const U8* const p \
+ |const UV result \
+ |NN U8* const ustrp \
+ |NN STRLEN *lenp
iR |bool |is_utf8_common |NN const U8 *const p|NN SV **swash|NN const char * const swashname|NULLOK SV* const invlist
sR |SV* |swatch_get |NN SV* swash|UV start|UV span
sRM |U8* |swash_scan_list_line|NN U8* l|NN U8* const lend|NN UV* min \
|Size_t count
Ap |Off_t |PerlIO_tell |NULLOK PerlIO *f
Ap |int |PerlIO_seek |NULLOK PerlIO *f|Off_t offset|int whence
+Xp |void |PerlIO_save_errno |NULLOK PerlIO *f
+Xp |void |PerlIO_restore_errno |NULLOK PerlIO *f
Ap |STDCHAR *|PerlIO_get_base |NULLOK PerlIO *f
Ap |STDCHAR *|PerlIO_get_ptr |NULLOK PerlIO *f
: pad API
Apda |PADLIST*|pad_new |int flags
+#ifdef DEBUGGING
+pX |void|set_padlist| NN CV * cv | NULLOK PADLIST * padlist
+#endif
#if defined(PERL_IN_PAD_C)
s |PADOFFSET|pad_alloc_name|NN SV *namesv|U32 flags \
|NULLOK HV *typestash|NULLOK HV *ourstash
Apd |void |pad_setsv |PADOFFSET po|NN SV* sv
#endif
pd |void |pad_block_start|int full
-pd |U32 |intro_my
+Apd |U32 |intro_my
pd |OP * |pad_leavemy
pd |void |pad_swipe |PADOFFSET po|bool refadjust
#if defined(PERL_IN_PAD_C)
pdX |void |pad_push |NN PADLIST *padlist|int depth
ApdR |HV* |pad_compname_type|const PADOFFSET po
#if defined(USE_ITHREADS)
-pdR |PADLIST *|padlist_dup |NULLOK PADLIST *srcpad \
+pdR |PADLIST *|padlist_dup |NN PADLIST *srcpad \
|NN CLONE_PARAMS *param
#endif
p |PAD ** |padlist_store |NN PADLIST *padlist|I32 key \
: XS_VERSION_BOOTCHECK
Xpo |void |xs_version_bootcheck|U32 items|U32 ax|NN const char *xs_p \
|STRLEN xs_len
-: This function is an implementation detail. The public API for this is
-: XS_APIVERSION_BOOTCHECK
-Xpo |void |xs_apiversion_bootcheck|NN SV *module|NN const char *api_p \
- |STRLEN api_len
-
+Xpon |I32 |xs_handshake |const U32 key|NN void * v_my_perl\
+ |NN const char * file| ...
+Xp |void |xs_boot_epilog |const U32 ax
#ifndef HAS_STRLCAT
Apnod |Size_t |my_strlcat |NULLOK char *dst|NULLOK const char *src|Size_t size
#endif
#define av_top_index(a) S_av_top_index(aTHX_ a)
#define av_undef(a) Perl_av_undef(aTHX_ a)
#define av_unshift(a,b) Perl_av_unshift(aTHX_ a,b)
+#define block_end(a,b) Perl_block_end(aTHX_ a,b)
#define block_gimme() Perl_block_gimme(aTHX)
+#define block_start(a) Perl_block_start(aTHX_ a)
#define bytes_cmp_utf8(a,b,c,d) Perl_bytes_cmp_utf8(aTHX_ a,b,c,d)
#define bytes_from_utf8(a,b,c) Perl_bytes_from_utf8(aTHX_ a,b,c)
#define bytes_to_utf8(a,b) Perl_bytes_to_utf8(aTHX_ a,b)
#define debstackptrs() Perl_debstackptrs(aTHX)
#define delimcpy Perl_delimcpy
#define despatch_signals() Perl_despatch_signals(aTHX)
+#ifndef PERL_IMPLICIT_CONTEXT
+#define die Perl_die
+#endif
+#define die_sv(a) Perl_die_sv(aTHX_ a)
#define do_binmode(a,b,c) Perl_do_binmode(aTHX_ a,b,c)
#define do_close(a,b) Perl_do_close(aTHX_ a,b)
#define do_gv_dump(a,b,c,d) Perl_do_gv_dump(aTHX_ a,b,c,d)
#define init_stacks() Perl_init_stacks(aTHX)
#define init_tm(a) Perl_init_tm(aTHX_ a)
#define instr Perl_instr
+#define intro_my() Perl_intro_my(aTHX)
#define isALNUM_lazy(a) Perl_isALNUM_lazy(aTHX_ a)
#define isIDFIRST_lazy(a) Perl_isIDFIRST_lazy(aTHX_ a)
#define is_ascii_string Perl_is_ascii_string
#define newCONSTSUB(a,b,c) Perl_newCONSTSUB(aTHX_ a,b,c)
#define newCONSTSUB_flags(a,b,c,d,e) Perl_newCONSTSUB_flags(aTHX_ a,b,c,d,e)
#define newCVREF(a,b) Perl_newCVREF(aTHX_ a,b)
+#define newDEFSVOP() Perl_newDEFSVOP(aTHX)
#define newFORM(a,b,c) Perl_newFORM(aTHX_ a,b,c)
#define newFOROP(a,b,c,d,e) Perl_newFOROP(aTHX_ a,b,c,d,e)
#define newGIVENOP(a,b,c) Perl_newGIVENOP(aTHX_ a,b,c)
#define op_append_elem(a,b,c) Perl_op_append_elem(aTHX_ a,b,c)
#define op_append_list(a,b,c) Perl_op_append_list(aTHX_ a,b,c)
#define op_contextualize(a,b) Perl_op_contextualize(aTHX_ a,b)
+#define op_convert_list(a,b,c) Perl_op_convert_list(aTHX_ a,b,c)
#define op_dump(a) Perl_op_dump(aTHX_ a)
#define op_free(a) Perl_op_free(aTHX_ a)
#define op_linklist(a) Perl_op_linklist(aTHX_ a)
#if !(defined(NO_MATHOMS))
#define sv_nounlocking(a) Perl_sv_nounlocking(aTHX_ a)
#endif
-#if !(defined(_MSC_VER))
-#ifndef PERL_IMPLICIT_CONTEXT
-#define die Perl_die
-#endif
-#define die_sv(a) Perl_die_sv(aTHX_ a)
-#define screaminstr(a,b,c,d,e,f) Perl_screaminstr(aTHX_ a,b,c,d,e,f)
-# if defined(PERL_IMPLICIT_CONTEXT)
-#define die_nocontext Perl_die_nocontext
-# endif
-#endif
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
#define my_bzero Perl_my_bzero
#endif
#if defined(PERL_IMPLICIT_CONTEXT)
#define croak_nocontext Perl_croak_nocontext
#define deb_nocontext Perl_deb_nocontext
+#define die_nocontext Perl_die_nocontext
#define form_nocontext Perl_form_nocontext
#define fprintf_nocontext Perl_fprintf_nocontext
#define load_module_nocontext Perl_load_module_nocontext
#define sv_setpvf_nocontext Perl_sv_setpvf_nocontext
#define warn_nocontext Perl_warn_nocontext
#define warner_nocontext Perl_warner_nocontext
-# if defined(_MSC_VER)
-#define die_nocontext Perl_die_nocontext
-# endif
#endif
#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_PERL_C) || defined(PERL_IN_UTF8_C)
#define _new_invlist_C_array(a) Perl__new_invlist_C_array(aTHX_ a)
#define do_spawn(a) Perl_do_spawn(aTHX_ a)
#define do_spawn_nowait(a) Perl_do_spawn_nowait(aTHX_ a)
#endif
-#if defined(_MSC_VER)
-#ifndef PERL_IMPLICIT_CONTEXT
-#define die Perl_die
-#endif
-#define die_sv(a) Perl_die_sv(aTHX_ a)
-#define screaminstr(a,b,c,d,e,f) Perl_screaminstr(aTHX_ a,b,c,d,e,f)
-#endif
#if defined(PERL_CORE) || defined(PERL_EXT)
#define av_reify(a) Perl_av_reify(aTHX_ a)
#define current_re_engine() Perl_current_re_engine(aTHX)
#define apply(a,b,c) Perl_apply(aTHX_ a,b,c)
#define av_extend_guts(a,b,c,d,e) Perl_av_extend_guts(aTHX_ a,b,c,d,e)
#define bind_match(a,b,c) Perl_bind_match(aTHX_ a,b,c)
-#define block_end(a,b) Perl_block_end(aTHX_ a,b)
-#define block_start(a) Perl_block_start(aTHX_ a)
#define boot_core_PerlIO() Perl_boot_core_PerlIO(aTHX)
#define boot_core_UNIVERSAL() Perl_boot_core_UNIVERSAL(aTHX)
#define boot_core_mro() Perl_boot_core_mro(aTHX)
#define ck_tell(a) Perl_ck_tell(aTHX_ a)
#define ck_trunc(a) Perl_ck_trunc(aTHX_ a)
#define closest_cop(a,b,c,d) Perl_closest_cop(aTHX_ a,b,c,d)
-#define convert(a,b,c) Perl_convert(aTHX_ a,b,c)
#define core_prototype(a,b,c,d) Perl_core_prototype(aTHX_ a,b,c,d)
#define coresub_op(a,b,c) Perl_coresub_op(aTHX_ a,b,c)
#define create_eval_scope(a) Perl_create_eval_scope(aTHX_ a)
#define init_argv_symbols(a,b) Perl_init_argv_symbols(aTHX_ a,b)
#define init_constants() Perl_init_constants(aTHX)
#define init_debugger() Perl_init_debugger(aTHX)
-#define intro_my() Perl_intro_my(aTHX)
#define invert(a) Perl_invert(aTHX_ a)
-#define io_close(a,b) Perl_io_close(aTHX_ a,b)
+#define io_close(a,b,c,d) Perl_io_close(aTHX_ a,b,c,d)
#define isinfnansv(a) Perl_isinfnansv(aTHX_ a)
#define jmaybe(a) Perl_jmaybe(aTHX_ a)
#define keyword(a,b,c) Perl_keyword(aTHX_ a,b,c)
#define newATTRSUB_x(a,b,c,d,e,f) Perl_newATTRSUB_x(aTHX_ a,b,c,d,e,f)
#define newSTUB(a,b) Perl_newSTUB(aTHX_ a,b)
#define newSVavdefelem(a,b,c) Perl_newSVavdefelem(aTHX_ a,b,c)
+#define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b)
#define newXS_len_flags(a,b,c,d,e,f,g) Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f,g)
#define nextargv(a,b) Perl_nextargv(aTHX_ a,b)
+#define noperl_die Perl_noperl_die
#define oopsAV(a) Perl_oopsAV(aTHX_ a)
#define oopsHV(a) Perl_oopsHV(aTHX_ a)
-#define op_const_sv(a,b) Perl_op_const_sv(aTHX_ a,b)
#define op_unscope(a) Perl_op_unscope(aTHX_ a)
#define package(a) Perl_package(aTHX_ a)
#define package_version(a) Perl_package_version(aTHX_ a)
#define wait4pid(a,b,c) Perl_wait4pid(aTHX_ a,b,c)
#define watch(a) Perl_watch(aTHX_ a)
#define write_to_stderr(a) Perl_write_to_stderr(aTHX_ a)
+#define xs_boot_epilog(a) Perl_xs_boot_epilog(aTHX_ a)
#define yyerror(a) Perl_yyerror(aTHX_ a)
#define yyerror_pv(a,b) Perl_yyerror_pv(aTHX_ a,b)
#define yyerror_pvn(a,b,c) Perl_yyerror_pvn(aTHX_ a,b,c)
# endif
# if defined(DEBUGGING)
#define get_debug_opts(a,b) Perl_get_debug_opts(aTHX_ a,b)
+#define set_padlist(a,b) Perl_set_padlist(aTHX_ a,b)
# if defined(PERL_IN_PAD_C)
#define cv_dump(a,b) S_cv_dump(aTHX_ a,b)
# endif
#define modkids(a,b) S_modkids(aTHX_ a,b)
#define move_proto_attr(a,b,c) S_move_proto_attr(aTHX_ a,b,c)
#define my_kid(a,b,c) S_my_kid(aTHX_ a,b,c)
-#define newDEFSVOP() S_newDEFSVOP(aTHX)
#define newGIVWHENOP(a,b,c,d,e) S_newGIVWHENOP(aTHX_ a,b,c,d,e)
#define newMETHOP_internal(a,b,c,d) S_newMETHOP_internal(aTHX_ a,b,c,d)
#define new_logop(a,b,c,d) S_new_logop(aTHX_ a,b,c,d)
#define no_bareword_allowed(a) S_no_bareword_allowed(aTHX_ a)
#define no_fh_allowed(a) S_no_fh_allowed(aTHX_ a)
-#define null_listop_in_list_context(a) S_null_listop_in_list_context(aTHX_ a)
#define op_integerize(a) S_op_integerize(aTHX_ a)
#define op_std_init(a) S_op_std_init(aTHX_ a)
#define pmtrans(a,b,c) S_pmtrans(aTHX_ a,b,c)
#define isa_lookup(a,b,c,d) S_isa_lookup(aTHX_ a,b,c,d)
# endif
# if defined(PERL_IN_UTF8_C)
-#define check_locale_boundary_crossing(a,b,c,d) S_check_locale_boundary_crossing(aTHX_ a,b,c,d)
+#define check_locale_boundary_crossing(a,b,c,d,e) S_check_locale_boundary_crossing(aTHX_ a,b,c,d,e)
#define is_utf8_common(a,b,c,d) S_is_utf8_common(aTHX_ a,b,c,d)
#define swash_scan_list_line(a,b,c,d,e,f,g) S_swash_scan_list_line(aTHX_ a,b,c,d,e,f,g)
#define swatch_get(a,b,c) S_swatch_get(aTHX_ a,b,c)
#define magic_setcollxfrm(a,b) Perl_magic_setcollxfrm(aTHX_ a,b)
#define mem_collxfrm(a,b,c) Perl_mem_collxfrm(aTHX_ a,b,c)
# endif
+# if defined(USE_PERLIO)
+#define PerlIO_restore_errno(a) Perl_PerlIO_restore_errno(aTHX_ a)
+#define PerlIO_save_errno(a) Perl_PerlIO_save_errno(aTHX_ a)
+# endif
# if defined(_MSC_VER)
#define magic_regdatum_set(a,b) Perl_magic_regdatum_set(aTHX_ a,b)
# endif
#define PL_XPosix_ptrs (vTHX->IXPosix_ptrs)
#define PL_Xpv (vTHX->IXpv)
#define PL_an (vTHX->Ian)
-#define PL_apiversion (vTHX->Iapiversion)
#define PL_argvgv (vTHX->Iargvgv)
#define PL_argvout_stack (vTHX->Iargvout_stack)
#define PL_argvoutgv (vTHX->Iargvoutgv)
#define PL_warnhook (vTHX->Iwarnhook)
#define PL_watchaddr (vTHX->Iwatchaddr)
#define PL_watchok (vTHX->Iwatchok)
+#define PL_xsubfilename (vTHX->Ixsubfilename)
#endif /* MULTIPLICITY */
# walkoptree comes from B.xs
BEGIN {
- $B::VERSION = '1.52';
+ $B::VERSION = '1.53';
@B::EXPORT_OK = ();
# Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.
=item NVX
+=item COP_SEQ_RANGE_LOW
+
+=item COP_SEQ_RANGE_HIGH
+
+These last two are only valid for pad name SVs.
+
=back
=head2 B::RV Methods
B::PADLIST
CvPADLIST(cv)
B::CV cv
+ CODE:
+ RETVAL = CvISXSUB(cv) ? NULL : CvPADLIST(cv);
+ OUTPUT:
+ RETVAL
#else
#endif
+SV *
+CvHSCXT(cv)
+ B::CV cv
+ CODE:
+ RETVAL = newSVuv(CvISXSUB(cv) ? PTR2UV(CvHSCXT(cv)) : 0);
+ OUTPUT:
+ RETVAL
+
void
CvXSUB(cv)
B::CV cv
use Exporter (); # use #5
-our $VERSION = "0.994";
+our $VERSION = "0.995";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw( set_style set_style_standard add_callback
concise_subref concise_cv concise_main
# to update the corresponding magic number in the next line.
# Remember, this needs to stay the last things in the module.
-# Why is this different for MacOS? Does it matter?
-my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11;
+my $cop_seq_mnum = 16;
$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
1;
my $core = grep { $_ eq 'PERL_CORE=1' } @ARGV;
-WriteMakefile(
- NAME => "B",
- VERSION_FROM => "B.pm",
- realclean => {FILES=> 'const-c.inc const-xs.inc'},
-);
-
my $headerpath;
if ($core) {
$headerpath = File::Spec->catdir(File::Spec->updir, File::Spec->updir);
my @names = ({ name => 'HEf_SVKEY', macro => 1, type => "IV" },
qw(SVTYPEMASK SVt_PVGV SVt_PVHV PAD_FAKELEX_ANON PAD_FAKELEX_MULTI));
+my @depend;
# First element in each tuple is the file; second is a regex snippet
# giving the prefix to limit the names of symbols to define that come
my $file = $tuple->[0];
my $pfx = $tuple->[1] || '';
my $path = File::Spec->catfile($headerpath, $file);
+ push @depend, $path;
open my $fh, '<', $path or die "Cannot open $path: $!";
while (<$fh>) {
push @names, $1 if (/ \#define \s+ ( $pfx \w+ ) \s+
close $fh;
}
+WriteMakefile(
+ NAME => "B",
+ VERSION_FROM => "B.pm",
+ realclean => {FILES=> 'const-c.inc const-xs.inc'},
+ depend => {'Makefile' => "@depend"},
+);
+
# Currently only SVt_PVGV and SVt_PVHV aren't macros, but everything we name
# should exist, so ensure that the C compile breaks if anything does not.
WriteConstants(
constant => [qw/ ASSIGN CVf_LVALUE
CVf_METHOD LIST_CONTEXT OP_CONST OP_LIST OP_RV2SV
- OP_AELEM
+ OP_AELEM OP_CUSTOM
OP_STRINGIFY OPf_KIDS OPf_MOD OPf_REF OPf_SPECIAL
OPf_PARENS
OPf_STACKED OPf_WANT OPf_WANT_LIST OPf_WANT_SCALAR
OPpSORT_INPLACE OPpSORT_INTEGER OPpSORT_NUMERIC
OPpSORT_REVERSE OPpREVERSE_INPLACE OPpTARGET_MY
OPpTRANS_COMPLEMENT OPpTRANS_DELETE OPpTRANS_SQUASH
+ OPpREPEAT_DOLIST
PMf_CONTINUE PMf_EVAL PMf_EXTENDED PMf_EXTENDED_MORE
PMf_FOLD PMf_GLOBAL
PMf_KEEP PMf_NONDESTRUCT
# 3 <0> pushmark s
# 4 <#> gv[*array] s
# 5 <1> rv2av[t8] lKM/1
-# 6 <@> mapstart lK* < 5.017002
-# 6 <@> mapstart lK >=5.017002
+# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t9] lK
# 8 <0> enter l
# 9 <;> nextstate(main 475 (eval 10):1) v:{
# goto 7
# g <0> pushmark s
# h <#> gv[*hash] s
-# i <1> rv2hv[t2] lKRM*/1 < 5.019006
-# i <1> rv2hv lKRM*/1 >=5.019006
+# i <1> rv2hv lKRM*/1
# j <2> aassign[t10] KS/COMMON
# k <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 3 <0> pushmark s
# 4 <$> gv(*array) s
# 5 <1> rv2av[t3] lKM/1
-# 6 <@> mapstart lK* < 5.017002
-# 6 <@> mapstart lK >=5.017002
+# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t4] lK
# 8 <0> enter l
# 9 <;> nextstate(main 559 (eval 15):1) v:{
# goto 7
# g <0> pushmark s
# h <$> gv(*hash) s
-# i <1> rv2hv[t1] lKRM*/1 < 5.019006
-# i <1> rv2hv lKRM*/1 >=5.019006
+# i <1> rv2hv lKRM*/1
# j <2> aassign[t5] KS/COMMON
# k <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 4 <0> pushmark s
# 5 <0> pushmark s
# 6 <#> gv[*hash] s
-# 7 <1> rv2hv[t2] lKRM*/1 < 5.019006
-# 7 <1> rv2hv lKRM*/1 >=5.019006
+# 7 <1> rv2hv lKRM*/1
# 8 <2> aassign[t3] vKS
# 9 <;> nextstate(main 476 (eval 10):1) v:{
# a <0> pushmark sM
# 4 <0> pushmark s
# 5 <0> pushmark s
# 6 <$> gv(*hash) s
-# 7 <1> rv2hv[t1] lKRM*/1 < 5.019006
-# 7 <1> rv2hv lKRM*/1 >=5.019006
+# 7 <1> rv2hv lKRM*/1
# 8 <2> aassign[t2] vKS
# 9 <;> nextstate(main 560 (eval 15):1) v:{
# a <0> pushmark sM
# 3 <0> pushmark s
# 4 <#> gv[*array] s
# 5 <1> rv2av[t7] lKM/1
-# 6 <@> mapstart lK* < 5.017002
-# 6 <@> mapstart lK >=5.017002
+# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t9] lK
-# 8 <0> pushmark s
-# 9 <#> gvsv[*_] s
-# a <1> lc[t4] sK/1
-# b <@> stringify[t5] sK/1
-# c <$> const[IV 1] s
-# d <@> list lK
-# - <@> scope lK < 5.017002
+# 8 <#> gvsv[*_] s
+# 9 <1> lc[t4] sK/1
+# a <$> const[IV 1] s
# goto 7
-# e <0> pushmark s
-# f <#> gv[*hash] s
-# g <1> rv2hv[t2] lKRM*/1 < 5.019006
-# g <1> rv2hv lKRM*/1 >=5.019006
-# h <2> aassign[t10] KS/COMMON
-# i <1> leavesub[1 ref] K/REFC,1
+# b <0> pushmark s
+# c <#> gv[*hash] s
+# d <1> rv2hv lKRM*/1
+# e <2> aassign[t10] KS/COMMON
+# f <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 560 (eval 15):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*array) s
# 5 <1> rv2av[t4] lKM/1
-# 6 <@> mapstart lK* < 5.017002
-# 6 <@> mapstart lK >=5.017002
+# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t5] lK
-# 8 <0> pushmark s
-# 9 <$> gvsv(*_) s
-# a <1> lc[t2] sK/1
-# b <@> stringify[t3] sK/1
-# c <$> const(IV 1) s
-# d <@> list lK
-# - <@> scope lK < 5.017002
+# 8 <$> gvsv(*_) s
+# 9 <1> lc[t2] sK/1
+# a <$> const(IV 1) s
# goto 7
-# e <0> pushmark s
-# f <$> gv(*hash) s
-# g <1> rv2hv[t1] lKRM*/1 < 5.019006
-# g <1> rv2hv lKRM*/1 >=5.019006
-# h <2> aassign[t6] KS/COMMON
-# i <1> leavesub[1 ref] K/REFC,1
+# b <0> pushmark s
+# c <$> gv(*hash) s
+# d <1> rv2hv lKRM*/1
+# e <2> aassign[t6] KS/COMMON
+# f <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 3 <0> pushmark s
# 4 <#> gv[*array] s
# 5 <1> rv2av[t7] lKM/1
-# 6 <@> mapstart lK* < 5.017002
-# 6 <@> mapstart lK >=5.017002
+# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t9] lK
-# 8 <0> pushmark s
-# 9 <#> gvsv[*_] s
-# a <1> lc[t4] sK/1
-# b <@> stringify[t5] sK/1
-# c <$> const[IV 1] s
-# d <@> list lKP
-# - <@> scope lK < 5.017002
+# 8 <#> gvsv[*_] s
+# 9 <1> lc[t4] sK/1
+# a <$> const[IV 1] s
# goto 7
-# e <0> pushmark s
-# f <#> gv[*hash] s
-# g <1> rv2hv[t2] lKRM*/1 < 5.019006
-# g <1> rv2hv lKRM*/1 >=5.019006
-# h <2> aassign[t10] KS/COMMON
-# i <1> leavesub[1 ref] K/REFC,1
+# b <0> pushmark s
+# c <#> gv[*hash] s
+# d <1> rv2hv lKRM*/1
+# e <2> aassign[t10] KS/COMMON
+# f <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 560 (eval 15):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*array) s
# 5 <1> rv2av[t4] lKM/1
-# 6 <@> mapstart lK* < 5.017002
-# 6 <@> mapstart lK >=5.017002
+# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t5] lK
-# 8 <0> pushmark s
-# 9 <$> gvsv(*_) s
-# a <1> lc[t2] sK/1
-# b <@> stringify[t3] sK/1
-# c <$> const(IV 1) s
-# d <@> list lKP
-# - <@> scope lK < 5.017002
+# 8 <$> gvsv(*_) s
+# 9 <1> lc[t2] sK/1
+# a <$> const(IV 1) s
# goto 7
-# e <0> pushmark s
-# f <$> gv(*hash) s
-# g <1> rv2hv[t1] lKRM*/1 < 5.019006
-# g <1> rv2hv lKRM*/1 >=5.019006
-# h <2> aassign[t6] KS/COMMON
-# i <1> leavesub[1 ref] K/REFC,1
+# b <0> pushmark s
+# c <$> gv(*hash) s
+# d <1> rv2hv lKRM*/1
+# e <2> aassign[t6] KS/COMMON
+# f <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 3 <0> pushmark s
# 4 <#> gv[*array] s
# 5 <1> rv2av[t6] lKM/1
-# 6 <@> mapstart lK* < 5.017002
-# 6 <@> mapstart lK >=5.017002
+# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t8] lK
-# 8 <0> pushmark s
-# 9 <#> gvsv[*_] s
-# a <1> lc[t4] sK/1
-# b <$> const[IV 1] s
-# c <@> list lK
-# - <@> scope lK < 5.017002
+# 8 <#> gvsv[*_] s
+# 9 <1> lc[t4] sK/1
+# a <$> const[IV 1] s
# goto 7
-# d <0> pushmark s
-# e <#> gv[*hash] s
-# f <1> rv2hv[t2] lKRM*/1 < 5.019006
-# f <1> rv2hv lKRM*/1 >=5.019006
-# g <2> aassign[t9] KS/COMMON
-# h <1> leavesub[1 ref] K/REFC,1
+# b <0> pushmark s
+# c <#> gv[*hash] s
+# d <1> rv2hv lKRM*/1
+# e <2> aassign[t9] KS/COMMON
+# f <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 589 (eval 26):1) v
# 2 <0> pushmark s
# 3 <0> pushmark s
# 4 <$> gv(*array) s
# 5 <1> rv2av[t3] lKM/1
-# 6 <@> mapstart lK* < 5.017002
-# 6 <@> mapstart lK >=5.017002
+# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t4] lK
-# 8 <0> pushmark s
-# 9 <$> gvsv(*_) s
-# a <1> lc[t2] sK/1
-# b <$> const(IV 1) s
-# c <@> list lK
-# - <@> scope lK < 5.017002
+# 8 <$> gvsv(*_) s
+# 9 <1> lc[t2] sK/1
+# a <$> const(IV 1) s
# goto 7
-# d <0> pushmark s
-# e <$> gv(*hash) s
-# f <1> rv2hv[t1] lKRM*/1 < 5.019006
-# f <1> rv2hv lKRM*/1 >=5.019006
-# g <2> aassign[t5] KS/COMMON
-# h <1> leavesub[1 ref] K/REFC,1
+# b <0> pushmark s
+# c <$> gv(*hash) s
+# d <1> rv2hv lKRM*/1
+# e <2> aassign[t5] KS/COMMON
+# f <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 5 <1> rv2av[t6] lKM/1
# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t7] lK
-# 8 <0> pushmark s
-# 9 <#> gvsv[*_] s
-# a <1> lc[t4] sK/1
-# b <$> const[IV 1] s
-# c <@> list lKP
+# 8 <#> gvsv[*_] s
+# 9 <1> lc[t4] sK/1
+# a <$> const[IV 1] s
# goto 7
-# d <0> pushmark s
-# e <#> gv[*hash] s
-# f <1> rv2hv[t2] lKRM*/1 < 5.019006
-# f <1> rv2hv lKRM*/1 >=5.019006
-# g <2> aassign[t8] KS/COMMON
-# h <1> leavesub[1 ref] K/REFC,1
+# b <0> pushmark s
+# c <#> gv[*hash] s
+# d <1> rv2hv lKRM*/1
+# e <2> aassign[t8] KS/COMMON
+# f <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 593 (eval 28):1) v
# 2 <0> pushmark s
# 5 <1> rv2av[t3] lKM/1
# 6 <@> mapstart lK
# 7 <|> mapwhile(other->8)[t4] lK
-# 8 <0> pushmark s
-# 9 <$> gvsv(*_) s
-# a <1> lc[t2] sK/1
-# b <$> const(IV 1) s
-# c <@> list lKP
+# 8 <$> gvsv(*_) s
+# 9 <1> lc[t2] sK/1
+# a <$> const(IV 1) s
# goto 7
-# d <0> pushmark s
-# e <$> gv(*hash) s
-# f <1> rv2hv[t1] lKRM*/1 < 5.019006
-# f <1> rv2hv lKRM*/1 >=5.019006
-# g <2> aassign[t5] KS/COMMON
-# h <1> leavesub[1 ref] K/REFC,1
+# b <0> pushmark s
+# c <$> gv(*hash) s
+# d <1> rv2hv lKRM*/1
+# e <2> aassign[t5] KS/COMMON
+# f <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# goto 7
# a <0> pushmark s
# b <#> gv[*hash] s
-# c <1> rv2hv[t2] lKRM*/1 < 5.019006
-# c <1> rv2hv lKRM*/1 >=5.019006
+# c <1> rv2hv lKRM*/1
# d <2> aassign[t6] KS/COMMON
# e <#> gv[*array] s
# f <1> rv2av[t8] K/1
# goto 7
# a <0> pushmark s
# b <$> gv(*hash) s
-# c <1> rv2hv[t1] lKRM*/1 < 5.019006
-# c <1> rv2hv lKRM*/1 >=5.019006
+# c <1> rv2hv lKRM*/1
# d <2> aassign[t4] KS/COMMON
# e <$> gv(*array) s
# f <1> rv2av[t5] K/1
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t5] KS/COMMON
+# a <2> aassign[t5] KS
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 545 (eval 15):1) v
# 7 <0> pushmark s
# 8 <$> gv(*articles) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t3] KS/COMMON
+# a <2> aassign[t3] KS
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t3] KS/COMMON
+# a <2> aassign[t3] KS
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
# 7 <0> pushmark s
# 8 <$> gv(*articles) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t2] KS/COMMON
+# a <2> aassign[t2] KS
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t10] KS/COMMON
+# a <2> aassign[t10] KS
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
# 7 <0> pushmark s
# 8 <$> gv(*articles) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t6] KS/COMMON
+# a <2> aassign[t6] KS
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t3] KS/COMMON
+# a <2> aassign[t3] KS
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
# 7 <0> pushmark s
# 8 <$> gv(*articles) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t2] KS/COMMON
+# a <2> aassign[t2] KS
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t3] KS/COMMON
+# a <2> aassign[t3] KS
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
# 7 <0> pushmark s
# 8 <$> gv(*articles) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t2] KS/COMMON
+# a <2> aassign[t2] KS
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t3] KS/COMMON
+# a <2> aassign[t3] KS
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
# 7 <0> pushmark s
# 8 <$> gv(*articles) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t2] KS/COMMON
+# a <2> aassign[t2] KS
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 8 <0> pushmark s
# 9 <#> gv[*sortedclass] s
# a <1> rv2av[t2] lKRM*/1
-# b <2> aassign[t5] KS/COMMON
+# b <2> aassign[t5] KS
# c <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
# 8 <0> pushmark s
# 9 <$> gv(*sortedclass) s
# a <1> rv2av[t1] lKRM*/1
-# b <2> aassign[t3] KS/COMMON
+# b <2> aassign[t3] KS
# c <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 8 <0> pushmark s
# 9 <#> gv[*new] s
# a <1> rv2av[t2] lKRM*/1
-# b <2> aassign[t5] KS/COMMON
+# b <2> aassign[t5] KS
# c <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 614 (eval 36):2) v:{
# 8 <0> pushmark s
# 9 <$> gv(*new) s
# a <1> rv2av[t1] lKRM*/1
-# b <2> aassign[t3] KS/COMMON
+# b <2> aassign[t3] KS
# c <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 8 <0> pushmark s
# 9 <#> gv[*new] s
# a <1> rv2av[t2] lKRM*/1
-# b <2> aassign[t5] KS/COMMON
+# b <2> aassign[t5] KS
# c <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
# 8 <0> pushmark s
# 9 <$> gv(*new) s
# a <1> rv2av[t1] lKRM*/1
-# b <2> aassign[t3] KS/COMMON
+# b <2> aassign[t3] KS
# c <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 7 <0> pushmark s
# 8 <#> gv[*new] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t14] KS/COMMON
+# a <2> aassign[t14] KS
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 578 (eval 15):1) v:%,{
# 7 <0> pushmark s
# 8 <$> gv(*new) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t6] KS/COMMON
+# a <2> aassign[t6] KS
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 7 <0> pushmark s
# 8 <#> gv[*new] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t14] KS/COMMON
+# a <2> aassign[t14] KS
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 578 (eval 15):1) v:%,{
# 7 <0> pushmark s
# 8 <$> gv(*new) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t6] KS/COMMON
+# a <2> aassign[t6] KS
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# 7 <0> pushmark s
# 8 <#> gv[*articles] s
# 9 <1> rv2av[t2] lKRM*/1
-# a <2> aassign[t8] KS/COMMON
+# a <2> aassign[t8] KS
# b <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 546 (eval 15):1) v
# 7 <0> pushmark s
# 8 <$> gv(*articles) s
# 9 <1> rv2av[t1] lKRM*/1
-# a <2> aassign[t4] KS/COMMON
+# a <2> aassign[t4] KS
# b <1> leavesub[1 ref] K/REFC,1
EONT_EONT
# a <0> pushmark s
# b <#> gv[*foo] s
# c <1> rv2av[t2] lKRM*/1
-# d <2> aassign[t6] KS/COMMON
+# d <2> aassign[t6] KS
# e <1> leavesub[1 ref] K/REFC,1
EOT_EOT
# 1 <;> nextstate(main 496 (eval 20):1) v:{
# a <0> pushmark s
# b <$> gv(*foo) s
# c <1> rv2av[t1] lKRM*/1
-# d <2> aassign[t4] KS/COMMON
+# d <2> aassign[t4] KS
# e <1> leavesub[1 ref] K/REFC,1
EONT_EONT
package Devel::Peek;
-$VERSION = '1.18';
+$VERSION = '1.19';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
$out
}
+sub B::Deparse::pp_Devel_Peek_Dump {
+ my ($deparse,$op,$cx) = @_;
+ my @kids = $deparse->deparse($op->first, 6);
+ my $sib = $op->first->sibling;
+ if (ref $sib ne 'B::NULL') {
+ push @kids, $deparse->deparse($sib, 6);
+ }
+ return "Devel::Peek::Dump(" . join(", ", @kids) . ")";
+}
+
1;
__END__
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) == SVt_PVCV) {
CV *cv = (CV*)sv;
- PADLIST* padlist = CvPADLIST(cv);
+ PADLIST* padlist;
AV *argav;
SV** svp;
SV** pad;
PerlIO_printf(Perl_debug_log, " busy\n");
continue;
}
+ padlist = CvPADLIST(cv);
svp = (SV**) PadlistARRAY(padlist);
while (++i <= PadlistMAX(padlist)) { /* Depth. */
SV **args;
assert(cv);
cv_set_call_checker(cv, S_ck_dump, (SV *)cv);
- XopENTRY_set(&my_xop, xop_name, "Dump");
+ XopENTRY_set(&my_xop, xop_name, "Devel_Peek_Dump");
XopENTRY_set(&my_xop, xop_desc, "Dump");
XopENTRY_set(&my_xop, xop_class, OA_BINOP);
Perl_custom_op_register(aTHX_ S_pp_dump, &my_xop);
/mge;
$pattern =~ s/^\h+COW_REFCNT = .*\n//mg
if $Config{ccflags} =~
- /-DPERL_(?:OLD_COPY_ON_WRITE|NO_COW)/
+ /-DPERL_(?:OLD_COPY_ON_WRITE|NO_COW)\b/
|| $] < 5.019003;
print $pattern, "\n" if $DEBUG;
my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
do_test('floating point value',
$d,
$] < 5.019003
- || $Config{ccflags} =~ /-DPERL_(?:NO_COW|OLD_COPY_ON_WRITE)/
+ || $Config{ccflags} =~ /-DPERL_(?:NO_COW|OLD_COPY_ON_WRITE)\b/
?
'SV = PVNV\\($ADDR\\) at $ADDR
REFCNT = 1
FLAGS = 0xc # $] >= 5.013 && $] < 5.015
FLAGS = 0x100c # $] >= 5.015
OUTSIDE_SEQ = 0
- PADLIST = 0x0
+ PADLIST = 0x0 # $] < 5.021006
+ HSCXT = $ADDR # $] >= 5.021006
OUTSIDE = 0x0 \\(null\\)');
do_test('isUV should show on PVMG',
}
my $e = <<'EODUMP';
-dumpindent is 4 at - line 1.
+dumpindent is 4 at -e line 1.
{
1 TYPE = leave ===> NULL
TARG = 1
$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" );
+my $out = t::runperl
+ switches => ['-Ilib'],
+ prog => 'package t; use Devel::Peek q-DumpProg-; DumpProg();',
+ stderr=>1;
+$out =~ s/ *SEQ = .*\n//;
+is $out, $e, "DumpProg() has no 'Attempt to free X prematurely' warning";
done_testing();
# Tim.Bunce@ig.co.uk, August 1994
BEGIN {
- $VERSION = '1.27';
+ $VERSION = '1.28';
}
use Config;
VERSION_FROM => 'DynaLoader_pm.PL',
PL_FILES => {'DynaLoader_pm.PL'=>'DynaLoader.pm'},
PM => {'DynaLoader.pm' => '$(INST_LIBDIR)/DynaLoader.pm'},
- depend => {'DynaLoader$(OBJ_EXT)' => 'dlutils.c'},
+ depend => { 'DynaLoader$(OBJ_EXT)' => 'dlutils.c',
+ 'DynaLoader.c' => 'DynaLoader.xs'},
clean => {FILES => 'DynaLoader.c DynaLoader.xs DynaLoader.pm'},
);
XS_DYNAMIC_FILENAME)));
-char *
+SV *
dl_error()
CODE:
dMY_CXT;
- RETVAL = dl_last_error ;
+ RETVAL = newSVsv(MY_CXT.x_dl_last_error);
OUTPUT:
RETVAL
XSRETURN(1);
-char *
+SV *
dl_error()
CODE:
dMY_CXT;
- RETVAL = dl_last_error ;
+ RETVAL = newSVsv(MY_CXT.x_dl_last_error);
OUTPUT:
RETVAL
XS_DYNAMIC_FILENAME)));
-char *
+SV *
dl_error()
CODE:
dMY_CXT;
- RETVAL = dl_last_error ;
+ RETVAL = newSVsv(MY_CXT.x_dl_last_error);
OUTPUT:
RETVAL
XS_DYNAMIC_FILENAME)));
-char *
+SV *
dl_error()
CODE:
dMY_CXT;
- RETVAL = dl_last_error ;
+ RETVAL = newSVsv(MY_CXT.x_dl_last_error);
OUTPUT:
RETVAL
XS_DYNAMIC_FILENAME)));
XSRETURN(1);
-char *
+SV *
dl_error()
- PREINIT:
- dMY_CXT;
CODE:
- RETVAL = dl_last_error ;
+ dMY_CXT;
+ RETVAL = newSVsv(MY_CXT.x_dl_last_error);
OUTPUT:
RETVAL
filename, NULL,
XS_DYNAMIC_FILENAME)));
-char *
+SV *
dl_error()
CODE:
dMY_CXT;
- RETVAL = dl_last_error ;
+ RETVAL = newSVsv(MY_CXT.x_dl_last_error);
OUTPUT:
RETVAL
XS_DYNAMIC_FILENAME)));
-char *
+SV *
dl_error()
CODE:
dMY_CXT;
- RETVAL = dl_last_error;
+ RETVAL = newSVsv(MY_CXT.x_dl_last_error);
OUTPUT:
RETVAL
XS_DYNAMIC_FILENAME)));
-char *
+SV *
dl_error()
CODE:
dMY_CXT;
- RETVAL = dl_last_error ;
+ RETVAL = newSVsv(MY_CXT.x_dl_last_error);
OUTPUT:
- RETVAL
+ RETVAL
#if defined(USE_ITHREADS)
dMY_CXT;
DWORD err = GetLastError();
STRLEN len;
- if (!dl_error_sv)
- dl_error_sv = newSVpvs("");
- PerlProc_GetOSError(dl_error_sv,err);
- return SvPV(dl_error_sv,len);
+ SV ** l_dl_error_svp = &dl_error_sv;
+ SV * l_dl_error_sv;
+ if (!*l_dl_error_svp)
+ *l_dl_error_svp = newSVpvs("");
+ l_dl_error_sv = *l_dl_error_svp;
+ PerlProc_GetOSError(l_dl_error_sv,err);
+ return SvPV(l_dl_error_sv,len);
}
static void
void
dl_load_file(filename,flags=0)
char * filename
- int flags
+#flags is unused
+ SV * flags = NO_INIT
PREINIT:
void *retv;
+ SV * retsv;
CODE:
{
+ PERL_UNUSED_VAR(flags);
DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename));
if (dl_static_linked(filename) == 0) {
retv = PerlProc_DynaLoad(filename);
else
retv = (void*) Win_GetModuleHandle(NULL);
DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", retv));
- ST(0) = sv_newmortal() ;
- if (retv == NULL)
+
+ if (retv == NULL) {
SaveError(aTHX_ "load_file:%s",
OS_Error_String(aTHX)) ;
+ retsv = &PL_sv_undef;
+ }
else
- sv_setiv( ST(0), (IV)retv);
+ retsv = sv_2mortal(newSViv((IV)retv));
+ ST(0) = retsv;
}
int
filename)));
-char *
+SV *
dl_error()
CODE:
dMY_CXT;
- RETVAL = dl_last_error;
+ RETVAL = newSVsv(MY_CXT.x_dl_last_error);
OUTPUT:
RETVAL
#endif
#define MY_CXT_KEY "DynaLoader::_guts" XS_VERSION
+/* disable version checking since DynaLoader can't be DynaLoaded */
+#undef dXSBOOTARGSXSAPIVERCHK
+#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK
+
typedef struct {
SV* x_dl_last_error; /* pointer to allocated memory for
last error message */
if ((sub = get_cvs("DynaLoader::dl_unload_file", 0)) != NULL) {
dl_librefs = get_av("DynaLoader::dl_librefs", 0);
+ EXTEND(SP,1);
while ((dl_libref = av_pop(dl_librefs)) != &PL_sv_undef) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(sv_2mortal(dl_libref));
+ PUSHs(sv_2mortal(dl_libref));
PUTBACK;
call_sv((SV*)sub, G_DISCARD | G_NODEBUG);
FREETMPS;
use strict;
use Config;
-use Test::More;
+require '../../t/test.pl';
+
my %modules;
my $db_file;
}
%modules = (
- # ModuleName => q| code to check that it was loaded |,
- 'List::Util' => q| ::is( ref List::Util->can('first'), 'CODE' ) |, # 5.7.2
- 'Cwd' => q| ::is( ref Cwd->can('fastcwd'),'CODE' ) |, # 5.7 ?
- 'File::Glob' => q| ::is( ref File::Glob->can('doglob'),'CODE' ) |, # 5.6
- $db_file => q| ::is( ref $db_file->can('TIEHASH'), 'CODE' ) |, # 5.0
- 'Socket' => q| ::is( ref Socket->can('inet_aton'),'CODE' ) |, # 5.0
- 'Time::HiRes'=> q| ::is( ref Time::HiRes->can('usleep'),'CODE' ) |, # 5.7.3
+ # ModuleName => q| code to check that it was loaded |,
+ 'List::Util' => q| ::is( ref List::Util->can('first'), 'CODE' ) |, # 5.7.2
+ 'Cwd' => q| ::is( ref Cwd->can('fastcwd'),'CODE' ) |, # 5.7 ?
+ 'File::Glob' => q| ::is( ref File::Glob->can('doglob'),'CODE' ) |, # 5.6
+ $db_file => q| ::is( ref $db_file->can('TIEHASH'), 'CODE' ) |, # 5.0
+ 'Socket' => q| ::is( ref Socket->can('inet_aton'),'CODE' ) |, # 5.0
+ 'Time::HiRes' => q| ::is( ref Time::HiRes->can('usleep'),'CODE' ) |, # 5.7.3
);
-plan tests => 26 + keys(%modules) * 3;
-
+plan (26 + keys(%modules) * 3);
# Try to load the module
use_ok( 'DynaLoader' );
can_ok( 'DynaLoader' => 'dl_load_file' ); # defined in XS section
can_ok( 'DynaLoader' => 'dl_undef_symbols' ); # defined in XS section
SKIP: {
- skip "unloading unsupported on $^O", 1 if ($old_darwin || $^O eq 'VMS');
+ skip( "unloading unsupported on $^O", 1 ) if ($old_darwin || $^O eq 'VMS');
can_ok( 'DynaLoader' => 'dl_unload_file' ); # defined in XS section
}
} else {
# Check error messages
# .. for bootstrap()
eval { DynaLoader::bootstrap() };
-like( $@, q{/^Usage: DynaLoader::bootstrap\(module\)/},
+like( $@, qr/^Usage: DynaLoader::bootstrap\(module\)/,
"calling DynaLoader::bootstrap() with no argument" );
eval { package egg_bacon_sausage_and_spam; DynaLoader::bootstrap("egg_bacon_sausage_and_spam") };
if ($Config{usedl}) {
- like( $@, q{/^Can't locate loadable object for module egg_bacon_sausage_and_spam/},
+ like( $@, qr/^Can't locate loadable object for module egg_bacon_sausage_and_spam/,
"calling DynaLoader::bootstrap() with a package without binary object" );
} else {
- like( $@, q{/^Can't load module egg_bacon_sausage_and_spam/},
+ like( $@, qr/^Can't load module egg_bacon_sausage_and_spam/,
"calling DynaLoader::bootstrap() with a package without binary object" );
}
# .. for dl_load_file()
SKIP: {
- skip "no dl_load_file with dl_none.xs", 2 unless $Config{usedl};
+ skip( "no dl_load_file with dl_none.xs", 2 ) unless $Config{usedl};
eval { DynaLoader::dl_load_file() };
- like( $@, q{/^Usage: DynaLoader::dl_load_file\(filename, flags=0\)/},
+ like( $@, qr/^Usage: DynaLoader::dl_load_file\(filename, flags=0\)/,
"calling DynaLoader::dl_load_file() with no argument" );
eval { no warnings 'uninitialized'; DynaLoader::dl_load_file(undef) };
eval { $dlhandle = DynaLoader::dl_load_file("egg_bacon_sausage_and_spam") };
$dlerr = DynaLoader::dl_error();
SKIP: {
- skip "dl_load_file() does not attempt to load file on VMS (and thus does not fail) when \@dl_require_symbols is empty", 1 if $^O eq 'VMS';
+ skip( "dl_load_file() does not attempt to load file on VMS (and thus does not fail) when \@dl_require_symbols is empty", 1 ) if $^O eq 'VMS';
ok( !$dlhandle, "calling DynaLoader::dl_load_file() without an existing library should fail" );
}
ok( defined $dlerr, "dl_error() returning an error message: '$dlerr'" );
# Some platforms are known to not have a "libc"
# (not at least by that name) that the dl_findfile()
# could find.
- skip "dl_findfile test not appropriate on $^O", 1
+ skip( "dl_findfile test not appropriate on $^O", 1 )
if $^O =~ /(win32|vms|openbsd|bitrig|cygwin|vos)/i;
# Play safe and only try this test if this system
# looks pretty much Unix-like.
- skip "dl_findfile test not appropriate on $^O", 1
+ skip( "dl_findfile test not appropriate on $^O", 1 )
unless -d '/usr' && -f '/bin/ls';
- skip "dl_findfile test not always appropriate when cross-compiling", 1
+ skip( "dl_findfile test not always appropriate when cross-compiling", 1 )
if $Config{usecrosscompile};
cmp_ok( scalar @files, '>=', 1, "array should contain one result result or more: libc => (@files)" );
}
SKIP: {
if ($extensions !~ /\b$module\b/) {
delete($modules{$module});
- skip "$module not available", 3;
+ skip( "$module not available", 3);
}
eval "use $module";
is( $@, '', "loading $module" );
my @loaded_modules = @DynaLoader::dl_modules;
for my $libref (reverse @DynaLoader::dl_librefs) {
TODO: {
- todo_skip "Can't safely unload with -DPERL_GLOBAL_STRUCT_PRIVATE (RT #119409)", 2
+ todo_skip( "Can't safely unload with -DPERL_GLOBAL_STRUCT_PRIVATE (RT #119409)", 2 )
if $Config{ccflags} =~ /(?:^|\s)-DPERL_GLOBAL_STRUCT_PRIVATE\b/;
SKIP: {
- skip "unloading unsupported on $^O", 2
+ skip( "unloading unsupported on $^O", 2 )
if ($old_darwin || $^O eq 'VMS');
my $module = pop @loaded_modules;
- skip "File::Glob sets PL_opfreehook", 2 if $module eq 'File::Glob';
+ skip( "File::Glob sets PL_opfreehook", 2 ) if $module eq 'File::Glob';
my $r = eval { DynaLoader::dl_unload_file($libref) };
is( $@, '', "calling dl_unload_file() for $module" );
is( $r, 1, " - unload was successful" );
}
SKIP: {
- skip "mod2fname not defined on this platform", 4
+ skip( "mod2fname not defined on this platform", 4 )
unless defined &DynaLoader::mod2fname && $Config{d_libname_unique};
is(
"mod2fname + libname_unique correctly truncates long names"
);
}
+
YESSTR
);
-our $VERSION = '0.11';
+our $VERSION = '0.12';
XSLoader::load();
I18N::Langinfo->import(qw(langinfo CODESET));
$codeset = langinfo(CODESET()); # note the ()
};
- if (!$@) { ... failed ... }
+ if ($@) { ... failed ... }
=head2 EXPORT
j0 j1 jn y0 y1 yn
- * Configure already (5.21.0) scans for:
+ * Configure already (5.21.5) scans for:
- fpclassify isfinite isinf isnan ilogb*l* signbit
+ copysign*l* fpclassify isfinite isinf isnan isnan*l* ilogb*l* signbit scalbn*l*
* For floating-point round mode (which matters for e.g. lrint and rint)
/* 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
+ * Though also remember lgamma_r. */
/* 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
+ * Also see the comments in hints/aix.sh about long doubles. */
-# 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
+#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
+# 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
+# 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
+# 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 tgammaq
+# 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(HAS_FREXPL) || defined(HAS_ILOGBL)) && defined(HAS_SQRTL)
+/* Use some of the Configure scans for long double math functions
+ * as the canary for all the C99 *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_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
+# 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 && defined(HAS_LLRINT)
+# define c99_lrint llrint
+# else
+# define c99_lrint lrint
+# endif
+# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLROUND)
+# 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
+# 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
+#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
/* XXX these isgreater/isnormal/isunordered macros definitions should
* be moved further in the file to be part of the emulations, so that
* platforms can e.g. #undef c99_isunordered and have it work like
* it does for the other interfaces. */
-# 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)) && \
+#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
+#endif
/* Check both the Configure symbol and the macro-ness (like C99 promises). */
-# if defined(HAS_FPCLASSIFY) && defined(fpclassify)
-# define c99_fpclassify fpclassify
-# endif
+#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
+#ifdef isnormal
+# define c99_isnormal isnormal
#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
-/* Tru64 is missing isunordered but we have emulation. */
-# undef c99_lrint
-# undef c99_lround
-# undef c99_nan /* in libm, but seems broken (no proto, either) */
-# undef c99_nearbyint
-# undef c99_nexttoward
-# undef c99_remquo
-# undef c99_round
-# undef c99_scalbn
-# 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
-/* XXX Regarding C99 math.h, VMS seems to be missing these:
-
- lround nan nearbyint round scalbn llrint
- */
+/* The Great Wall of Undef where according to the definedness of HAS_FOO symbols
+ * the corresponding c99_foo wrappers are undefined. This list doesn't include
+ * the isfoo() interfaces because they are either type-aware macros, or dealt
+ * separately, already in perl.h */
-#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
+#ifndef HAS_ACOSH
+# undef c99_acosh
#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
+#ifndef HAS_ASINH
+# undef c99_asinh
+#endif
+#ifndef HAS_ATANH
+# undef c99_atanh
+#endif
+#ifndef HAS_CBRT
+# undef c99_cbrt
+#endif
+#ifndef HAS_COPYSIGN
+# undef c99_copysign
+#endif
+#ifndef HAS_ERF
# undef c99_erf
+#endif
+#ifndef HAS_ERFC
# undef c99_erfc
+#endif
+#ifndef HAS_EXP2
# undef c99_exp2
+#endif
+#ifndef HAS_EXPM1
+# undef c99_expm1
+#endif
+#ifndef HAS_FDIM
# undef c99_fdim
+#endif
+#ifndef HAS_FMA
# undef c99_fma
+#endif
+#ifndef HAS_FMAX
# undef c99_fmax
+#endif
+#ifndef HAS_FMIN
# undef c99_fmin
+#endif
+#ifndef HAS_FPCLASSIFY
+# undef c99_fpclassify
+#endif
+#ifndef HAS_HYPOT
+# undef c99_hypot
+#endif
+#ifndef HAS_ILOGB
# undef c99_ilogb
+#endif
+#ifndef HAS_LGAMMA
# undef c99_lgamma
+#endif
+#ifndef HAS_LOG1P
# undef c99_log1p
+#endif
+#ifndef HAS_LOG2
# undef c99_log2
+#endif
+#ifndef HAS_LOGB
+# undef c99_logb
+#endif
+#ifndef HAS_LRINT
# undef c99_lrint
+#endif
+#ifndef HAS_LROUND
# undef c99_lround
+#endif
+#ifndef HAS_NAN
+# undef c99_nan
+#endif
+#ifndef HAS_NEARBYINT
+# undef c99_nearbyint
+#endif
+#ifndef HAS_NEXTAFTER
+# undef c99_nextafter
+#endif
+#ifndef HAS_NEXTTOWARD
+# undef c99_nexttoward
+#endif
+#ifndef HAS_REMAINDER
+# undef c99_remainder
+#endif
+#ifndef HAS_REMQUO
# undef c99_remquo
+#endif
+#ifndef HAS_RINT
# undef c99_rint
+#endif
+#ifndef HAS_ROUND
+# undef c99_round
+#endif
+#ifndef HAS_SCALBN
+# undef c99_scalbn
+#endif
+#ifndef HAS_SIGNBIT
# undef c99_signbit
+#endif
+#ifndef HAS_TGAMMA
# undef c99_tgamma
+#endif
+#ifndef HAS_TRUNC
# undef c99_trunc
+#endif
+
+#ifdef WIN32
/* Some APIs exist under Win32 with "underbar" names. */
# undef c99_hypot
#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)
#ifndef c99_fdim
static NV my_fdim(NV x, NV y)
{
- return x > y ? x - y : 0;
+ return (Perl_isnan(x) || Perl_isnan(y)) ? NV_NAN : (x > y ? x - y : 0);
}
# define c99_fdim my_fdim
#endif
+#ifndef c99_fma
+static NV my_fma(NV x, NV y, NV z)
+{
+ return (x * y) + z;
+}
+# define c99_fma my_fma
+#endif
+
#ifndef c99_fmax
static NV my_fmax(NV x, NV y)
{
# define c99_ilogb my_ilogb
#endif
-/* XXX lgamma -- non-trivial */
+/* tgamma and lgamma emulations based on
+ * http://www.johndcook.com/cpp_gamma.html,
+ * code placed in public domain.
+ *
+ * Note that these implementations (neither the johndcook originals
+ * nor these) do NOT set the global signgam variable. This is not
+ * necessarily a bad thing. */
+
+/* Note that the tgamma() and lgamma() implementations
+ * here depend on each other. */
+
+#ifndef HAS_TGAMMA
+static NV my_tgamma(NV x);
+# define c99_tgamma my_tgamma
+#endif
+#ifndef HAS_LGAMMA
+static NV my_lgamma(NV x);
+# define c99_lgamma my_lgamma
+#endif
+
+#ifndef HAS_TGAMMA
+static NV my_tgamma(NV x)
+{
+ const NV gamma = 0.577215664901532860606512090; /* Euler's gamma constant. */
+ if (Perl_isnan(x) || x < 0.0)
+ return NV_NAN;
+ if (x == 0.0 || x == NV_INF)
+ return x == -0.0 ? -NV_INF : NV_INF;
+
+ /* The function domain is split into three intervals:
+ * (0, 0.001), [0.001, 12), and (12, infinity) */
+
+ /* First interval: (0, 0.001)
+ * For small values, 1/tgamma(x) has power series x + gamma x^2,
+ * so in this range, 1/tgamma(x) = x + gamma x^2 with error on the order of x^3.
+ * The relative error over this interval is less than 6e-7. */
+ if (x < 0.001)
+ return 1.0 / (x * (1.0 + gamma * x));
+
+ /* Second interval: [0.001, 12) */
+ if (x < 12.0) {
+ double y = x; /* Working copy. */
+ int n = 0;
+ /* Numerator coefficients for approximation over the interval (1,2) */
+ static const NV p[] = {
+ -1.71618513886549492533811E+0,
+ 2.47656508055759199108314E+1,
+ -3.79804256470945635097577E+2,
+ 6.29331155312818442661052E+2,
+ 8.66966202790413211295064E+2,
+ -3.14512729688483675254357E+4,
+ -3.61444134186911729807069E+4,
+ 6.64561438202405440627855E+4
+ };
+ /* Denominator coefficients for approximation over the interval (1, 2) */
+ static const NV q[] = {
+ -3.08402300119738975254353E+1,
+ 3.15350626979604161529144E+2,
+ -1.01515636749021914166146E+3,
+ -3.10777167157231109440444E+3,
+ 2.25381184209801510330112E+4,
+ 4.75584627752788110767815E+3,
+ -1.34659959864969306392456E+5,
+ -1.15132259675553483497211E+5
+ };
+ NV num = 0.0;
+ NV den = 1.0;
+ NV z;
+ NV result;
+ int i;
+
+ if (x < 1.0)
+ y += 1.0;
+ else {
+ n = Perl_floor(y) - 1;
+ y -= n;
+ }
+ z = y - 1;
+ for (i = 0; i < 8; i++) {
+ num = (num + p[i]) * z;
+ den = den * z + q[i];
+ }
+ result = num / den + 1.0;
+
+ if (x < 1.0) {
+ /* Use the identity tgamma(z) = tgamma(z+1)/z
+ * The variable "result" now holds tgamma of the original y + 1
+ * Thus we use y - 1 to get back the original y. */
+ result /= (y - 1.0);
+ }
+ else {
+ /* Use the identity tgamma(z+n) = z*(z+1)* ... *(z+n-1)*tgamma(z) */
+ for (i = 0; i < n; i++)
+ result *= y++;
+ }
+
+ return result;
+ }
+
+ /* Third interval: [12, +Inf) */
+ if (x > 171.624) { /* XXX Too low for quad precision */
+ return NV_INF;
+ }
+
+ return Perl_exp(c99_lgamma(x));
+}
+#endif
+
+#ifndef HAS_LGAMMA
+static NV my_lgamma(NV x)
+{
+ if (Perl_isnan(x))
+ return NV_NAN;
+ if (x <= 0 || x == NV_INF)
+ return NV_INF;
+ if (x == 1.0 || x == 2.0)
+ return 0;
+ if (x < 12.0)
+ return Perl_log(PERL_ABS(c99_tgamma(x)));
+ /* Abramowitz and Stegun 6.1.41
+ * Asymptotic series should be good to at least 11 or 12 figures
+ * For error analysis, see Whittiker and Watson
+ * A Course in Modern Analysis (1927), page 252 */
+ {
+ static const NV c[8] = {
+ 1.0/12.0,
+ -1.0/360.0,
+ 1.0/1260.0,
+ -1.0/1680.0,
+ 1.0/1188.0,
+ -691.0/360360.0,
+ 1.0/156.0,
+ -3617.0/122400.0
+ };
+ NV z = 1.0 / (x * x);
+ NV sum = c[7];
+ static const NV half_log_of_two_pi =
+ 0.91893853320467274178032973640562;
+ NV series;
+ int i;
+ for (i = 6; i >= 0; i--) {
+ sum *= z;
+ sum += c[i];
+ }
+ series = sum / x;
+ return (x - 0.5) * Perl_log(x) - x + half_log_of_two_pi + series;
+ }
+}
+#endif
#ifndef c99_log1p
static NV my_log1p(NV x)
/* Toward plus infinity. */
#define MY_ROUND_UP(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x))))
+#if (!defined(c99_nearbyint) || !defined(c99_lrint)) && defined(FE_TONEAREST)
static NV my_rint(NV x)
{
#ifdef FE_TONEAREST
return NV_NAN;
#endif
}
+#endif
/* XXX nearbyint() and rint() are not really identical -- but the difference
* is messy: nearbyint is defined NOT to raise FE_INEXACT floating point
/* 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
+/* tgamma -- see lgamma */
/* XXX tanh (though c89) */
#endif
break;
case 16:
- /* XXX lgamma_r -- the lgamma accesses a global variable (signgam),
+ /* XXX Note: the lgamma modifies a global variable (signgam),
* which is evil. Some platforms have lgamma_r, which has
- * extra parameter instead of the global variable. */
+ * extra output parameter instead of the global variable. */
#ifdef c99_lgamma
RETVAL = c99_lgamma(x);
#else
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
default:
#ifdef Perl_signbit
RETVAL = Perl_signbit(x);
+#else
+ RETVAL = (x < 0) || (x == -0.0);
#endif
break;
}
CODE:
#ifdef c99_fma
RETVAL = c99_fma(x, y, z);
-#else
- RETVAL = NV_NAN;
- not_here("fma");
#endif
OUTPUT:
RETVAL
#ifdef c99_nan
RETVAL = c99_nan(s ? s : "");
#elif defined(NV_NAN)
+ PERL_UNUSED_VAR(s);
/* XXX if s != NULL, warn about unused argument,
* or implement the nan payload setting. */
RETVAL = NV_NAN;
our ($AUTOLOAD, %SIGRT);
-our $VERSION = '1.45';
+our $VERSION = '1.46';
require XSLoader;
between(-0.77, tanh(-1), -0.76, 'tanh(-1)');
cmp_ok(tanh(1), '==', -tanh(-1), 'tanh(1) == -tanh(-1)');
+sub near {
+ my ($got, $want, $msg, $eps) = @_;
+ $eps ||= 1e-6;
+ cmp_ok(abs($got - $want), '<', $eps, $msg);
+}
+
SKIP: {
+ my $C99_SKIP = 63;
+
unless ($Config{d_acosh}) {
- skip "no acosh, suspecting no C99 math", 30;
+ skip "no acosh, suspecting no C99 math", $C99_SKIP;
}
if ($^O =~ /Win32|VMS/) {
- skip "running in $^O, C99 math support uneven", 30;
+ skip "running in $^O, C99 math support uneven", $C99_SKIP;
}
- 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");
+ near(M_SQRT2, 1.4142135623731, "M_SQRT2", 1e-9);
+ near(M_E, 2.71828182845905, "M_E", 1e-9);
+ near(M_PI, 3.14159265358979, "M_PI", 1e-9);
+ near(acosh(2), 1.31695789692482, "acosh", 1e-9);
+ near(asinh(1), 0.881373587019543, "asinh", 1e-9);
+ near(atanh(0.5), 0.549306144334055, "atanh", 1e-9);
+ near(cbrt(8), 2, "cbrt", 1e-9);
+ near(cbrt(-27), -3, "cbrt", 1e-9);
+ near(copysign(3.14, -2), -3.14, "copysign", 1e-9);
+ near(expm1(2), 6.38905609893065, "expm1", 1e-9);
+ near(expm1(1e-6), 1.00000050000017e-06, "expm1", 1e-9);
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(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");
+ near(hypot(-2, 1), sqrt(5), "hypot -1 2", 1e-9);
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");
- }
+ ok(isfinite(1), "isfinite 1");
+ ok(!isfinite(Inf), "isfinite Inf");
+ ok(!isfinite(NaN), "isfinite NaN");
+ ok(isinf(INFINITY), "isinf INFINITY");
+ ok(isinf(Inf), "isinf Inf");
+ ok(!isinf(NaN), "isinf NaN");
+ ok(!isinf(42), "isinf 42");
+ 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
- }
+ near(log1p(2), 1.09861228866811, "log1p", 1e-9);
+ near(log1p(1e-6), 9.99999500000333e-07, "log1p", 1e-9);
+ near(log2(8), 3, "log2", 1e-9);
+ 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");
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");
-}
+ near(erf(1), 0.842700792949715, "erf 1", 1.5e-7);
+ near(erfc(1), 0.157299207050285, "erfc 1", 1.5e-7);
+ near(tgamma(9), 40320, "tgamma 9", 1.5e-7);
+ near(lgamma(9), 10.6046029027452, "lgamma 9", 1.5e-7);
+
+ # If adding more tests here, update also the $C99_SKIP
+ # at the beginning of this SKIP block.
+} # SKIP
done_testing();
unlike( $@, qr/Can't use string .* as a symbol ref/, "Can import autoloaded constants" );
SKIP: {
- skip("localeconv() not present", 20) unless $Config{d_locconv};
+ skip("localeconv() not present", 26) unless $Config{d_locconv};
my $conv = localeconv;
is(ref $conv, 'HASH', 'localconv returns a hash reference');
package PerlIO::encoding;
use strict;
-our $VERSION = '0.19';
+our $VERSION = '0.20';
our $DEBUG = 0;
$DEBUG and warn __PACKAGE__, " called by ", join(", ", caller), "\n";
if (avail == 0)
PerlIOBase(f)->flags |= PERLIO_F_EOF;
else
+ {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ Perl_PerlIO_save_errno(aTHX_ f);
+ }
}
FREETMPS;
LEAVE;
package PerlIO::scalar;
-our $VERSION = '0.19';
+our $VERSION = '0.20';
require XSLoader;
XSLoader::load();
1;
if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
SETERRNO(EBADF, SS_IVCHAN);
+ Perl_PerlIO_save_errno(aTHX_ f);
return 0;
}
{
__lyrics_:[__are_.__very_^.__sappy_]__but_^.__rhymes_^.__are_.__true_ unixify /__lyrics_/__are_/__very_.__sappy_/__but_.__rhymes_.__are_.__true_ ^
[.$(macro)] unixify $(macro)/ ^
^+foo.tmp unixify +foo.tmp ^
+[-.foo^_^_bar] unixify ../foo\ \ bar/ ^*
# and back again
/__some_/__where_/__over_/__the_.__rainbow_ vmsify __some_:[__where_.__over_]__the_.__rainbow_ ^
foo-bar-0^.01/ vmsify [.foo-bar-0_01] [.foo-bar-0^.01]
\ foo.tmp vmsify ^_foo.tmp ^
+foo.tmp vmsify ^+foo.tmp ^
+../foo\ \ bar/ vmsify [-.foo^_^_bar] ^
# Fileifying directory specs
__down_:[__the_.__garden_.__path_] fileify __down_:[__the_.__garden_]__path_.dir;1 ^
[.__down_.__the_.__garden_.__path_] fileify [.__down_.__the_.__garden_]__path_.dir;1 ^
use warnings;
use Carp;
-our $VERSION = '0.65';
+our $VERSION = '0.68';
require XSLoader;
}
}
foreach (keys %{$exports||{}}) {
- next unless /\A(?:rpn|calcrpn|stufftest|swaptwostmts|looprest|scopelessblock|stmtasexpr|stmtsasexpr|loopblock|blockasexpr|swaplabel|labelconst|arrayfullexpr|arraylistexpr|arraytermexpr|arrayarithexpr|arrayexprflags)\z/;
+ next unless /\A(?:rpn|calcrpn|stufftest|swaptwostmts|looprest|scopelessblock|stmtasexpr|stmtsasexpr|loopblock|blockasexpr|swaplabel|labelconst|arrayfullexpr|arraylistexpr|arraytermexpr|arrayarithexpr|arrayexprflags|DEFSV|with_vars|join_with_space)\z/;
$^H{"XS::APItest/$_"} = 1;
delete $exports->{$_};
}
=over
+=item DEFSV
+
+Behaves like C<$_>.
+
=item rpn(EXPRESSION)
This construct is a Perl expression. I<EXPRESSION> must be an RPN
static SV *hintkey_arrayfullexpr_sv, *hintkey_arraylistexpr_sv;
static SV *hintkey_arraytermexpr_sv, *hintkey_arrayarithexpr_sv;
static SV *hintkey_arrayexprflags_sv;
+static SV *hintkey_DEFSV_sv;
+static SV *hintkey_with_vars_sv;
+static SV *hintkey_join_with_space_sv;
static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
/* low-level parser helpers */
return o ? newANONLIST(o) : newANONHASH(newOP(OP_STUB, 0));
}
+#define parse_keyword_DEFSV() THX_parse_keyword_DEFSV(aTHX)
+static OP *THX_parse_keyword_DEFSV(pTHX)
+{
+ return newDEFSVOP();
+}
+
+#define sv_cat_c(a,b) THX_sv_cat_c(aTHX_ a, b)
+static void THX_sv_cat_c(pTHX_ SV *sv, U32 c) {
+ char ds[UTF8_MAXBYTES + 1], *d;
+ d = (char *)uvchr_to_utf8((U8 *)ds, c);
+ if (d - ds > 1) {
+ sv_utf8_upgrade(sv);
+ }
+ sv_catpvn(sv, ds, d - ds);
+}
+
+#define parse_keyword_with_vars() THX_parse_keyword_with_vars(aTHX)
+static OP *THX_parse_keyword_with_vars(pTHX)
+{
+ I32 c;
+ IV count;
+ int save_ix;
+ OP *vardeclseq, *body;
+
+ save_ix = block_start(TRUE);
+ vardeclseq = NULL;
+
+ count = 0;
+
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ while (c != '{') {
+ SV *varname;
+ PADOFFSET padoff;
+
+ if (c == -1) {
+ croak("unexpected EOF; expecting '{'");
+ }
+
+ if (!isIDFIRST_uni(c)) {
+ croak("unexpected '%c'; expecting an identifier", (int)c);
+ }
+
+ varname = newSVpvs("$");
+ if (lex_bufutf8()) {
+ SvUTF8_on(varname);
+ }
+
+ sv_cat_c(varname, c);
+ lex_read_unichar(0);
+
+ while (c = lex_peek_unichar(0), c != -1 && isIDCONT_uni(c)) {
+ sv_cat_c(varname, c);
+ lex_read_unichar(0);
+ }
+
+ padoff = pad_add_name_sv(varname, padadd_NO_DUP_CHECK, NULL, NULL);
+
+ {
+ OP *my_var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8));
+ my_var->op_targ = padoff;
+
+ vardeclseq = op_append_list(
+ OP_LINESEQ,
+ vardeclseq,
+ newSTATEOP(
+ 0, NULL,
+ newASSIGNOP(
+ OPf_STACKED,
+ my_var, 0,
+ newSVOP(
+ OP_CONST, 0,
+ newSViv(++count)
+ )
+ )
+ )
+ );
+ }
+
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ }
+
+ intro_my();
+
+ body = parse_block(0);
+
+ return block_end(save_ix, op_append_list(OP_LINESEQ, vardeclseq, body));
+}
+
+#define parse_join_with_space() THX_parse_join_with_space(aTHX)
+static OP *THX_parse_join_with_space(pTHX)
+{
+ OP *delim, *args;
+
+ args = parse_listexpr(0);
+ delim = newSVOP(OP_CONST, 0, newSVpvs(" "));
+ return op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, delim, args));
+}
+
/* plugin glue */
#define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
keyword_active(hintkey_arrayexprflags_sv)) {
*op_ptr = parse_keyword_arrayexprflags();
return KEYWORD_PLUGIN_EXPR;
+ } else if(keyword_len == 5 && strnEQ(keyword_ptr, "DEFSV", 5) &&
+ keyword_active(hintkey_DEFSV_sv)) {
+ *op_ptr = parse_keyword_DEFSV();
+ return KEYWORD_PLUGIN_EXPR;
+ } else if(keyword_len == 9 && strnEQ(keyword_ptr, "with_vars", 9) &&
+ keyword_active(hintkey_with_vars_sv)) {
+ *op_ptr = parse_keyword_with_vars();
+ return KEYWORD_PLUGIN_STMT;
+ } else if(keyword_len == 15 && strnEQ(keyword_ptr, "join_with_space", 15) &&
+ keyword_active(hintkey_join_with_space_sv)) {
+ *op_ptr = parse_join_with_space();
+ return KEYWORD_PLUGIN_EXPR;
} else {
return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
}
hintkey_arraytermexpr_sv = newSVpvs_share("XS::APItest/arraytermexpr");
hintkey_arrayarithexpr_sv = newSVpvs_share("XS::APItest/arrayarithexpr");
hintkey_arrayexprflags_sv = newSVpvs_share("XS::APItest/arrayexprflags");
+ hintkey_DEFSV_sv = newSVpvs_share("XS::APItest/DEFSV");
+ hintkey_with_vars_sv = newSVpvs_share("XS::APItest/with_vars");
+ hintkey_join_with_space_sv = newSVpvs_share("XS::APItest/join_with_space");
next_keyword_plugin = PL_keyword_plugin;
PL_keyword_plugin = my_keyword_plugin;
}
CODE:
sv_unmagicext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
+void
+sv_magic(SV *sv, SV *thingy)
+CODE:
+ sv_magic(SvRV(sv), NULL, PERL_MAGIC_ext, (const char *)thingy, 0);
+
UV
test_get_vtbl()
PREINIT:
/* We have to be in a different .xs so that we can do this: */
#undef XS_VERSION
-#define XS_VERSION ""
+#define XS_VERSION " "
#undef PERL_API_VERSION_STRING
#define PERL_API_VERSION_STRING "1.0.16"
#include "XSUB.h"
use warnings;
use strict;
-use Test::More tests => 76;
+use Test::More tests => 78;
use XS::APItest;
sub MODIFY_CODE_ATTRIBUTES { cv_set_call_checker_lists($_[1]); () }
BEGIN {
*foo2 = sub($$) :Attr { $foo_got = [ @_ ]; return "z"; };
+ my $foo = 3;
+ *foo3 = sub() :Attr { $foo };
}
$foo_got = undef;
is_deeply $foo_got, [ qw(a b), qw(a b c) ];
is $foo_ret, "z";
+eval q{$foo_ret = foo3(@b, @c);};
+is $@, "";
+is $foo_ret, 3;
+
cv_set_call_checker_lists(\&foo);
undef &foo;
$foo_got = undef;
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+use XS::APItest qw(join_with_space);
+
+sub foo { 'A' .. 'C' }
+
+my $bar = 42;
+my @baz = ('x', 'y');
+
+my $str = join_with_space $bar, foo, @baz;
+is $str, "42 A B C x y";
is(test_get_vtbl(), 0, 'get_vtbl(-1) returns NULL');
+use Scalar::Util 'weaken';
+eval { sv_magic(\!0, $foo) };
+is $@, "", 'PERL_MAGIC_ext is permitted on read-only things';
+
done_testing;
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 16;
+
+use XS::APItest qw(DEFSV);
+
+is $_, undef;
+is DEFSV, undef;
+is \DEFSV, \$_;
+
+DEFSV = "foo";
+is DEFSV, "foo";
+is $_, "foo";
+
+$_ = "bar";
+is DEFSV, "bar";
+is $_, "bar";
+
+{
+ no warnings 'experimental::lexical_topic';
+ my $_;
+
+ is $_, undef;
+ is DEFSV, undef;
+ is \DEFSV, \$_;
+
+ DEFSV = "lex-foo";
+ is DEFSV, "lex-foo";
+ is $_, "lex-foo";
+
+ $_ = "lex-bar";
+ is DEFSV, "lex-bar";
+ is $_, "lex-bar";
+}
+
+is DEFSV, "bar";
+is $_, "bar";
}
is (DPeek ($|), 'PVMG(1)', '$|');
- "abc" =~ m/(b)/; # Don't know why these magic vars have this content
-like (DPeek ($1), qr'^PVMG\("', ' $1');
+ "abc" =~ m/b/; # Don't know why these magic vars have this content
+ () = $1 || '';
+ is (DPeek ($1), 'PVMG()', ' $1');
is (DPeek ($`), 'PVMG()', ' $`');
is (DPeek ($&), 'PVMG()', ' $&');
is (DPeek ($'), 'PVMG()', " \$'");
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 18;
+
+use XS::APItest qw(with_vars);
+
+my $foo = "A"; my $rfoo = \$foo;
+my $bar = "B"; my $rbar = \$bar;
+my $baz = "C"; my $rbaz = \$baz;
+
+with_vars foo bar baz {
+ is $foo, 1;
+ is $$rfoo, "A";
+ isnt \$foo, $rfoo;
+
+ is $bar, 2;
+ is $$rbar, "B";
+ isnt \$bar, $rbar;
+
+ is $baz, 3;
+ is $$rbaz, "C";
+ isnt \$baz, $rbaz;
+}
+
+is $foo, "A";
+is \$foo, $rfoo;
+
+is $bar, "B";
+is \$bar, $rbar;
+
+is $baz, "C";
+is \$baz, $rbaz;
+
+with_vars x {
+ is $x, 1;
+}
+
+is eval('$x++'), undef;
+like $@, qr/explicit package name/;
use strict;
use warnings;
-our $VERSION = "0.27";
+our $VERSION = "0.28";
our @ISA = qw(Exporter);
our @EXPORT_OK = ('regmust',
qw(is_regexp regexp_pattern
#include "XSUB.h"
#include "re_comp.h"
+#undef dXSBOOTARGSXSAPIVERCHK
+/* skip API version checking due to different interp struct size but,
+ this hack is until #123007 is resolved */
+#define dXSBOOTARGSXSAPIVERCHK dXSBOOTARGSNOVERCHK
START_EXTERN_C
GvCVGEN(gv) = 0;
CvISXSUB_on(cv);
CvXSUB(cv) = core_xsub;
+ PoisonPADLIST(cv);
}
CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE
from PL_curcop. */
return TRUE;
}
+/* gv_magicalize only turns on the SVf_READONLY flag, not SVf_PROTECT. So
+ redefine SvREADONLY_on for that purpose. We don’t use it later on in
+ this file. */
+#undef SvREADONLY_on
+#define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
+
/* gv_magicalize() is called by gv_fetchpvn_flags when creating
* a new GV.
* Note that it does not insert the GV into the stash prior to
return addmg;
}
+/* If we do ever start using this later on in the file, we need to make
+ sure we don’t accidentally use the wrong definition. */
+#undef SvREADONLY_on
+
/* This function is called when the stash already holds the GV of the magic
* variable we're looking for, but we need to check that it has the correct
* kind of magic. For example, if someone first uses $! and then %!, the
(void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
SvREFCNT_dec(hv);
}
+ if (io && SvREFCNT(io) == 1 && IoIFP(io)
+ && (IoTYPE(io) == IoTYPE_WRONLY ||
+ IoTYPE(io) == IoTYPE_RDWR ||
+ IoTYPE(io) == IoTYPE_APPEND)
+ && ckWARN_d(WARN_IO)
+ && IoIFP(io) != PerlIO_stdin()
+ && IoIFP(io) != PerlIO_stdout()
+ && IoIFP(io) != PerlIO_stderr()
+ && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+ io_close(io, gv, FALSE, TRUE);
SvREFCNT_dec(io);
SvREFCNT_dec(cv);
SvREFCNT_dec(form);
#define TYPE_DIGITS(T) BIT_DIGITS(sizeof(T) * 8)
#define TYPE_CHARS(T) (TYPE_DIGITS(T) + 2) /* sign, NUL */
+/* Unused by core; should be deprecated */
#define Ctl(ch) ((ch) & 037)
/* This is a helper macro to avoid preprocessor issues, replaced by nothing
#ifdef EBCDIC
# ifndef _ALL_SOURCE
- /* This returns the wrong results on at least z/OS unless this is
- * defined. */
+ /* The native libc isascii() et.al. functions return the wrong results
+ * on at least z/OS unless this is defined. */
# error _ALL_SOURCE should probably be defined
# endif
-
- /* We could be called without perl.h, in which case NATIVE_TO_ASCII() is
- * likely not defined, and so we use the native function */
-# define isASCII(c) cBOOL(isascii(c))
#else
+ /* There is a simple definition of ASCII for ASCII platforms. But the
+ * EBCDIC one isn't so simple, so is defined using table look-up like the
+ * other macros below */
# define isASCII(c) ((WIDEST_UTYPE)(c) < 128)
#endif
-#define isASCII_A(c) isASCII(c)
-#define isASCII_L1(c) isASCII(c)
-
/* The lower 3 bits in both the ASCII and EBCDIC representations of '0' are 0,
* and the 8 possible permutations of those bits exactly comprise the 8 octal
* digits */
#define isOCTAL_A(c) cBOOL(FITS_IN_8_BITS(c) && (0xF8 & (c)) == '0')
-/* ASCII range only */
#ifdef H_PERL /* If have access to perl.h, lookup in its table */
/* Character class numbers. For internal core Perl use only. The ones less
# define isWORDCHAR_L1(c) _generic_isCC(c, _CC_WORDCHAR)
# define isIDFIRST_L1(c) _generic_isCC(c, _CC_IDFIRST)
+# ifdef EBCDIC
+# define isASCII(c) _generic_isCC(c, _CC_ASCII)
+# endif
+
/* Participates in a single-character fold with a character above 255 */
# define _HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(c) ((! cBOOL(FITS_IN_8_BITS(c))) || (PL_charclass[(U8) (c)] & _CC_mask(_CC_NONLATIN1_SIMPLE_FOLD)))
_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 */
+#else /* else we don't have perl.h H_PERL */
/* If we don't have perl.h, we are compiling a utility program. Below we
* hard-code various macro definitions that wouldn't otherwise be available
- * to it. */
-# ifdef EBCDIC
- /* Use the native functions. They likely will return false for all
- * non-ASCII values, but this makes sure */
-# define isLOWER_A(c) (isASCII(c) && islower(c))
-# define isPRINT_A(c) (isASCII(c) && isprint(c))
-# define isUPPER_A(c) (isASCII(c) && isupper(c))
-# else /* ASCII platform. These are coded based on first principals */
+ * to it. Most are coded based on first principals. First some ones common
+ * to both ASCII and EBCDIC */
+# define isDIGIT_A(c) ((c) <= '9' && (c) >= '0')
+# define isBLANK_A(c) ((c) == ' ' || (c) == '\t')
+# define isSPACE_A(c) (isBLANK_A(c) \
+ || (c) == '\n' \
+ || (c) == '\r' \
+ || (c) == '\v' \
+ || (c) == '\f')
+# ifdef EBCDIC /* There are gaps between 'i' and 'j'; 'r' and 's'. Same
+ for uppercase. This is ordered to exclude most things
+ early */
+# define isLOWER_A(c) ((c) >= 'a' && (c) <= 'z' \
+ && ((c) <= 'i' \
+ || ((c) >= 'j' && (c) <= 'r') \
+ || (c) >= 's'))
+# define isUPPER_A(c) ((c) >= 'A' && (c) <= 'Z' \
+ && ((c) <= 'I' \
+ || ((c) >= 'J' && (c) <= 'R') \
+ || (c) >= 'S'))
+# else /* ASCII platform. */
# define isLOWER_A(c) ((c) >= 'a' && (c) <= 'z')
-# define isPRINT_A(c) (((c) >= 32 && (c) < 127))
# define isUPPER_A(c) ((c) <= 'Z' && (c) >= 'A')
-# endif /* Below are common definitions for ASCII and non-ASCII */
+# endif
+
+ /* Some more ASCII, non-ASCII common definitions */
# define isALPHA_A(c) (isUPPER_A(c) || isLOWER_A(c))
# define isALPHANUMERIC_A(c) (isALPHA_A(c) || isDIGIT_A(c))
-# define isBLANK_A(c) ((c) == ' ' || (c) == '\t')
-# define isCNTRL_A(c) (isASCII(c) && (! isPRINT_A(c)))
-# define isDIGIT_A(c) ((c) <= '9' && (c) >= '0')
-# define isGRAPH_A(c) (isPRINT_A(c) && (c) != ' ')
-# define isIDFIRST_A(c) (isALPHA_A(c) || (c) == '_')
-# define isPUNCT_A(c) (isGRAPH_A(c) && (! isALPHANUMERIC_A(c)))
-# define isSPACE_A(c) ((c) == ' ' \
- || (c) == '\t' \
- || (c) == '\n' \
- || (c) == '\r' \
- || (c) == '\v' \
- || (c) == '\f')
# define isWORDCHAR_A(c) (isALPHANUMERIC_A(c) || (c) == '_')
-# define isXDIGIT_A(c) (isDIGIT_A(c) \
- || ((c) >= 'a' && (c) <= 'f') \
+# define isIDFIRST_A(c) (isALPHA_A(c) || (c) == '_')
+# define isXDIGIT_A(c) (isDIGIT_A(c) \
+ || ((c) >= 'a' && (c) <= 'f') \
|| ((c) <= 'F' && (c) >= 'A'))
+# ifdef EBCDIC
+# define isPUNCT_A(c) ((c) == '-' || (c) == '!' || (c) == '"' \
+ || (c) == '#' || (c) == '$' || (c) == '%' \
+ || (c) == '&' || (c) == '\'' || (c) == '(' \
+ || (c) == ')' || (c) == '*' || (c) == '+' \
+ || (c) == ',' || (c) == '.' || (c) == '/' \
+ || (c) == ':' || (c) == ';' || (c) == '<' \
+ || (c) == '=' || (c) == '>' || (c) == '?' \
+ || (c) == '@' || (c) == '[' || (c) == '\\' \
+ || (c) == ']' || (c) == '^' || (c) == '_' \
+ || (c) == '`' || (c) == '{' || (c) == '|' \
+ || (c) == '}' || (c) == '~')
+# define isGRAPH_A(c) (isALPHANUMERIC_A(c) || isPUNCT_A(c))
+# define isPRINT_A(c) (isGRAPH_A(c) || (c) == ' ')
+
+# ifdef QUESTION_MARK_CTRL
+# define _isQMC(c) ((c) == QUESTION_MARK_CTRL)
+# else
+# define _isQMC(c) 0
+# endif
+
+ /* I (khw) can't think of a way to define all the ASCII controls
+ * without resorting to a libc (locale-sensitive) call. But we know
+ * that all controls but the question-mark one are in the range 0-0x3f.
+ * This makes sure that all the controls that have names are included,
+ * and all controls that are also considered ASCII in the locale. This
+ * may include more or fewer than what it actually should, but the
+ * wrong ones are less-important controls, so likely won't impact
+ * things (keep in mind that this is compiled only if perl.h isn't
+ * available). The question mark control is included if available */
+# define isCNTRL_A(c) (((c) < 0x40 && isascii(c)) \
+ || (c) == '\0' || (c) == '\a' || (c) == '\b' \
+ || (c) == '\f' || (c) == '\n' || (c) == '\r' \
+ || (c) == '\t' || (c) == '\v' || _isQMC(c))
+
+# define isASCII(c) (isCNTRL_A(c) || isPRINT_A(c))
+# else /* ASCII platform; things are simpler, and isASCII has already
+ been defined */
+# define isGRAPH_A(c) (((c) > ' ' && (c) < 127))
+# define isPRINT_A(c) (isGRAPH_A(c) || (c) == ' ')
+# define isPUNCT_A(c) (isGRAPH_A(c) && (! isALPHANUMERIC_A(c)))
+# define isCNTRL_A(c) (isASCII(c) && (! isPRINT_A(c)))
+# endif
+
/* The _L1 macros may be unnecessary for the utilities; I (khw) added them
- * during debugging, and it seems best to keep them. */
+ * during debugging, and it seems best to keep them. We may be called
+ * without NATIVE_TO_LATIN1 being defined. On ASCII platforms, it doesn't
+ * do anything anyway, so make it not a problem */
+# if ! defined(EBCDIC) && ! defined(NATIVE_TO_LATIN1)
+# define NATIVE_TO_LATIN1(ch) (ch)
+# endif
# define isPSXSPC_A(c) isSPACE_A(c) /* XXX Assumes SPACE matches '\v' */
# define isALPHA_L1(c) (isUPPER_L1(c) || isLOWER_L1(c))
# define isALPHANUMERIC_L1(c) (isALPHA_L1(c) || isDIGIT_A(c))
/* And these aren't accurate at all. They are useful only for above
* Latin1, which utilities and bootstrapping don't deal with */
# define _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c) 0
+# define _HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(c) 0
# define _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(c) 0
/* Many of the macros later in this file are defined in terms of these. By
(FITS_IN_8_BITS(c) && S_bootstrap_ctype((U8) (c), (classnum), TRUE))
# define _generic_isCC_A(c, classnum) \
(FITS_IN_8_BITS(c) && S_bootstrap_ctype((U8) (c), (classnum), FALSE))
-#endif /* End of no perl.h */
+#endif /* End of no perl.h H_PERL */
#define isALPHANUMERIC(c) isALPHANUMERIC_A(c)
#define isALPHA(c) isALPHA_A(c)
+#define isASCII_A(c) isASCII(c)
+#define isASCII_L1(c) isASCII(c)
#define isBLANK(c) isBLANK_A(c)
#define isCNTRL(c) isCNTRL_A(c)
#define isDIGIT(c) isDIGIT_A(c)
#if defined(HAS_ISBLANK)
# define isBLANK_LC(c) _generic_LC(c, _CC_BLANK, isblank)
#else /* Unlike isASCII, varies if in a UTF-8 locale */
-# define isBLANK_LC(c) (IN_UTF8_CTYPE_LOCALE) ? isBLANK_L1(c) : isBLANK(c)
+# define isBLANK_LC(c) ((IN_UTF8_CTYPE_LOCALE) ? isBLANK_L1(c) : isBLANK(c))
#endif
#define _LC_CAST U8
#ifdef EBCDIC
/* Because all controls are UTF-8 invariants in EBCDIC, we can use this
* more efficient macro instead of the more general one */
-# define isCNTRL_utf8(p) isCNTRL_L1(p)
+# define isCNTRL_utf8(p) isCNTRL_L1(*(p))
#else
# define isCNTRL_utf8(p) _generic_utf8(_CC_CNTRL, p, 0)
#endif
* the outlier from the block that contains the other controls, just like
* toCTRL('?') on ASCII yields DEL, the control that is the outlier from the C0
* block. If it weren't special cased, it would yield a non-control.
- * The conversion works both ways, so CTRL('D') is 4, and CTRL(4) is D, etc. */
+ * The conversion works both ways, so toCTRL('D') is 4, and toCTRL(4) is D,
+ * etc. */
#ifndef EBCDIC
-# define toCTRL(c) (toUPPER(c) ^ 64)
+# define toCTRL(c) (__ASSERT_(FITS_IN_8_BITS(c)) toUPPER(c) ^ 64)
#else
-# define toCTRL(c) ((isPRINT_A(c)) \
- ? UNLIKELY((c) == '?') \
- ? QUESTION_MARK_CTRL \
- : (NATIVE_TO_LATIN1(toUPPER(c)) ^ 64) \
- : UNLIKELY((c) == QUESTION_MARK_CTRL) \
- ? ((c) == '?') \
- : (LATIN1_TO_NATIVE((c) ^ 64)))
+# define toCTRL(c) (__ASSERT_(FITS_IN_8_BITS(c)) \
+ ((isPRINT_A(c)) \
+ ? (UNLIKELY((c) == '?') \
+ ? QUESTION_MARK_CTRL \
+ : (NATIVE_TO_LATIN1(toUPPER(c)) ^ 64)) \
+ : (UNLIKELY((c) == QUESTION_MARK_CTRL) \
+ ? '?' \
+ : (LATIN1_TO_NATIVE((c) ^ 64)))))
#endif
/* Line numbers are unsigned, 32 bits. */
# 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.5
+# mkdir -p /opt/perl-catamount/lib/perl5/5.21.6
# 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.5
+# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.21.6
# 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
+# These are in libm, but seem broken (there are no protos in headers,
+# or man pages, either)
+d_fdim='undef'
+d_fma='undef'
+d_fmax='undef'
+d_fmin='undef'
+d_llrint='undef'
+d_llround='undef'
+d_lrint='undef'
+d_lround='undef'
+d_nan='undef'
+d_nearbyint='undef'
+d_round='undef'
+d_scalbn='undef'
+
#
# Unset temporary variables no more needed.
#
# Meanwhile, the following workaround should be safe on all versions
# of FreeBSD.
d_printf_format_null='undef'
+
d_locconv='undef'
d_setlocale='undef'
d_setlocale_r='undef'
+d_lc_monetary_2008='undef'
i_locale='undef'
# https://code.google.com/p/android-source-browsing/source/browse/libc/netbsd/net/getservent_r.c?repo=platform--bionic&r=ca6fe7bebe3cc6ed7e2db5a3ede2de0fcddf411d#95
;;
esac
+# libquadmath is sometimes installed as gcc internal library,
+# so contrary to our usual policy of *not* looking at gcc internal
+# directories we now *do* look at them, in case they contain
+# the quadmath library.
+# XXX This may apply to other gcc internal libraries, if such exist.
+# XXX This could be at Configure level, but then the $gcc is messy.
+case "$usequadmath" in
+"$define")
+ for d in `LANG=C LC_ALL=C $gcc $ccflags $ldflags -print-search-dirs | grep libraries | cut -f2- -d= | tr ':' $trnl | grep 'gcc' | sed -e 's:/$::'`
+ do
+ case `ls $d/*libquadmath*$so* 2>/dev/null` in
+ $d/*libquadmath*$so*) xlibpth="$xlibpth $d" ;;
+ esac
+ done
+ ;;
+esac
+
case "$libc" in
'')
# If you have glibc, then report the version for ./myconfig bug reporting.
# under a compiler other than c89.
case "$usedl" in
define)
-echo 'cat >.$$.c; '"$cc"' -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -D_SHR_ENVIRON -E -Wc,"LANGLVL(DOLLARINNAMES)",NOLOC ${1+"$@"} .$$.c | grep -v "??="; rm .$$.c' > cppstdin
+echo 'cat >.$$.c; '"$cc"' -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -D_SHR_ENVIRON -E -Wc,"LANGLVL(DOLLARINNAMES)",NOLOC ${1+"$@"} .$$.c | fgrep -v "??="; rm .$$.c' > cppstdin
;;
*)
-echo 'cat >.$$.c; '"$cc"' -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -E -Wc,"LANGLVL(DOLLARINNAMES)",NOLOC ${1+"$@"} .$$.c | grep -v "??="; rm .$$.c' > cppstdin
+echo 'cat >.$$.c; '"$cc"' -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -E -Wc,"LANGLVL(DOLLARINNAMES)",NOLOC ${1+"$@"} .$$.c | fgrep -v "??="; rm .$$.c' > cppstdin
;;
esac
d_gethostbyname_r='undef'
d_gethostent_r='undef'
+# The z/OS C compiler compiler supports the attribute keyword, but in a
+# limited manner.
+#
+# Ideally, Configure's tests should test the attributes as they are expected
+# to be used in perl, and, ideally, those tests would fail on z/OS.
+# Until then, just tell Configure to ignore the attributes. Currently,
+# Configure thinks attributes are supported because it does not recognize
+# warning messages like this:
+#
+# INFORMATIONAL CCN4108 ./proto.h:4534 The use of keyword '__attribute__' is non-portable.
+
+d_attribute_deprecated='undef'
+d_attribute_format='undef'
+d_attribute_malloc='undef'
+d_attribute_nonnull='undef'
+d_attribute_noreturn='undef'
+d_attribute_pure='undef'
+d_attribute_unused='undef'
+d_attribute_warn_unused_result='undef'
}
#endif
+/* ------------------------------- pad.h ------------------------------ */
+
+#if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
+PERL_STATIC_INLINE bool
+PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
+{
+ /* is seq within the range _LOW to _HIGH ?
+ * This is complicated by the fact that PL_cop_seqmax
+ * may have wrapped around at some point */
+ if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
+ return FALSE; /* not yet introduced */
+
+ if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
+ /* in compiling scope */
+ if (
+ (seq > COP_SEQ_RANGE_LOW(pn))
+ ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
+ : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
+ )
+ return TRUE;
+ }
+ else if (
+ (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
+ ?
+ ( seq > COP_SEQ_RANGE_LOW(pn)
+ || seq <= COP_SEQ_RANGE_HIGH(pn))
+
+ : ( seq > COP_SEQ_RANGE_LOW(pn)
+ && seq <= COP_SEQ_RANGE_HIGH(pn))
+ )
+ return TRUE;
+ return FALSE;
+}
+#endif
+
/* ----------------------------- regexp.h ----------------------------- */
PERL_STATIC_INLINE struct regexp *
PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
- if (pv && len > 1) {
+ if (len > 1) {
char *null_at;
if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
SETERRNO(ENOENT, LIB_INVARG);
PERLVARI(I, statname, SV *, NULL)
#ifdef HAS_TIMES
-/* Will be removed soon after v5.21.5. See RT #121351 */
+/* Will be removed soon after v5.21.6. See RT #121351 */
PERLVAR(I, timesbuf, struct tms)
#endif
PERLVAR(I, incgv, GV *)
PERLVAR(I, hintgv, GV *)
PERLVAR(I, origfilename, char *)
+PERLVARI(I, xsubfilename, const char *, NULL)
PERLVAR(I, diehook, SV *)
PERLVAR(I, warnhook, SV *)
/* switches */
PERLVAR(I, patchlevel, SV *)
-PERLVAR(I, apiversion, SV *)
PERLVAR(I, localpatches, const char * const *)
PERLVARI(I, splitstr, const char *, " ")
/* Hook for File::Glob */
PERLVARI(I, globhook, globhook_t, NULL)
-/* The last unconditional member of the interpreter structure when 5.21.5 was
+/* The last unconditional member of the interpreter structure when 5.21.6 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. */
/if.pm
/lib.pm
/mro.pm
+/ok.pm
/ops.pm
/parent.pm
/perlfaq.pm
OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPf_PARENS
OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
- OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
+ OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST
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 PMf_EXTENDED_MORE);
-$VERSION = '1.29';
+$VERSION = '1.30';
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
-BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem]) {
+BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem
+ custom ]) {
eval "sub OP_\U$_ () { " . opnumber($_) . "}"
}}
type => OP_PUSHMARK,
name => 'pushmark',
private => ($op->private & OPpLVAL_INTRO),
- next => ($op->flags & OPf_SPECIAL)
- ? $op->sibling->first
- : $op->sibling,
};
}
next unless $AF eq $0 || exists $self->{'files'}{$AF};
}
push @{$self->{'protos_todo'}}, [$pack . $key, undef];
+ } elsif ($class eq "IV") {
+ # A reference. Dump this if it is a reference to a CV.
+ if (class(my $cv = $val->RV) eq "CV") {
+ $self->todo($cv, 0);
+ }
} elsif ($class eq "GV") {
if (class(my $cv = $val->CV) ne "SPECIAL") {
next if $self->{'subs_done'}{$$val}++;
sub AUTOLOAD {
if ($AUTOLOAD =~ s/^.*::pp_//) {
- warn "unexpected OP_".uc $AUTOLOAD;
+ warn "unexpected OP_".
+ ($_[1]->type == OP_CUSTOM ? "CUSTOM ($AUTOLOAD)" : uc $AUTOLOAD);
return "XXX";
} else {
die "Undefined subroutine $AUTOLOAD called";
$i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
next;
}
- $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
+ my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2);
+ $expr2 =~ s/^sub :/+sub :/; # statement label otherwise
+ $expr .= $expr2;
$expr =~ s/;\n?\z//;
$callback->($expr, $i);
}
sub cop_subs {
my ($self, $op, $out_seq) = @_;
my $seq = $op->cop_seq;
- # If we have nephews, then our sequence number indicates
- # the cop_seq of the end of some sort of scope.
- if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
+ if ($] < 5.021006) {
+ # If we have nephews, then our sequence number indicates
+ # the cop_seq of the end of some sort of scope.
+ if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
and my $nseq = $self->find_scope_st($op->sibling) ) {
$seq = $nseq;
+ }
}
$seq = $out_seq if defined($out_seq) && $out_seq < $seq;
return $self->seq_subs($seq);
#push @text, "# ($seq)\n";
return "" if !defined $seq;
+ my @pending;
while (scalar(@{$self->{'subs_todo'}})
and $seq > $self->{'subs_todo'}[0][0]) {
+ my $cv = $self->{'subs_todo'}[0][1];
+ my $outside = $cv && $cv->OUTSIDE;
+ if ($cv and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}}) {
+ push @pending, shift @{$self->{'subs_todo'}};
+ next;
+ }
push @text, $self->next_todo;
}
+ unshift @{$self->{'subs_todo'}}, @pending;
return @text;
}
if ($flags & SWAP_CHILDREN) {
($left, $right) = ($right, $left);
}
+ my $leftop = $left;
$left = $self->deparse_binop_left($op, $left, $prec);
$left = "($left)" if $flags & LIST_CONTEXT
- && $left !~ /^(my|our|local|)[\@\(]/;
+ and $left !~ /^(my|our|local|)[\@\(]/
+ || do {
+ # Parenthesize if the left argument is a
+ # lone repeat op.
+ my $left = $leftop->first->sibling;
+ $left->name eq 'repeat'
+ && null($left->sibling);
+ };
$right = $self->deparse_binop_right($op, $right, $prec);
return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
}
return $self->maybe_parens("$left .$eq $right", $cx, $prec);
}
+sub pp_repeat { maybe_targmy(@_, \&repeat) }
+
# 'x' is weird when the left arg is a list
-sub pp_repeat {
+sub repeat {
my $self = shift;
my($op, $cx) = @_;
my $left = $op->first;
$prec = 7;
}
if (null($right)) { # list repeat; count is inside left-side ex-list
+ # in 5.21.5 and earlier
my $kid = $left->first->sibling; # skip pushmark
my @exprs;
for (; !null($kid->sibling); $kid = $kid->sibling) {
$right = $kid;
$left = "(" . join(", ", @exprs). ")";
} else {
- $left = $self->deparse_binop_left($op, $left, $prec);
+ my $dolist = $op->private & OPpREPEAT_DOLIST;
+ $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec);
+ if ($dolist) {
+ $left = "($left)";
+ }
}
$right = $self->deparse_binop_right($op, $right, $prec);
return $self->maybe_parens("$left x$eq $right", $cx, $prec);
}
maybe_local(@_, listop(@_, "substr"))
}
-sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
+sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) }
sub pp_index { maybe_targmy(@_, \&listop, "index") }
sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
sub pp_mapstart { baseop(@_, "map") }
sub pp_grepstart { baseop(@_, "grep") }
+my %uses_intro;
+BEGIN {
+ @uses_intro{
+ eval { require B::Op_private }
+ ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}}
+ : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice
+ hslice delete padsv padav padhv enteriter entersub padrange
+ pushmark cond_expr refassign list)
+ } = ();
+ delete @uses_intro{qw( lvref lvrefslice lvavref )};
+}
+
sub pp_list {
my $self = shift;
my($op, $cx) = @_;
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,
- # like OP_AELEMFAST, won't be immediate children of a list.
- #
- # OP_ENTERSUB and OP_SPLIT can break this logic, so check for them.
- # I suspect that open and exit can too.
- # XXX This really needs to be rewritten to accept only those ops
- # known to take the OPpLVAL_INTRO flag.
-
my $lopname = $lop->name;
my $loppriv = $lop->private;
- if (!($loppriv & (OPpLVAL_INTRO|OPpOUR_INTRO)
- or $lopname eq "undef")
- or $lopname =~ /^(?:entersub|exit|open|split
- |lv(?:av)?ref(?:slice)?)\z/x)
- {
- $local = ""; # or not
- last;
- }
my $newtype;
- if ($lopname =~ /^pad[ash]v$/) {
+ if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) {
if ($loppriv & OPpPAD_STATE) { # state()
($local = "", last) if $local !~ /^(?:either|state)$/;
$local = "state";
)) {
$newtype = $t;
}
- } elsif ($lopname ne "undef"
- # specifically avoid the "reverse sort" optimisation,
- # where "reverse" is nullified
- && !($lopname eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
+ } elsif ($lopname ne 'undef'
+ and !($loppriv & OPpLVAL_INTRO)
+ || !exists $uses_intro{$lopname eq 'null'
+ ? substr B::ppname($lop->targ), 3
+ : $lopname})
+ {
+ $local = ""; # or not
+ last;
+ } elsif ($lopname ne "undef")
{
# local()
($local = "", last) if $local !~ /^(?:either|local)$/;
my $cond = $op->first;
my $true = $cond->sibling;
- return $self->deparse($true, $cx);
+ my $ret = $self->deparse($true, $cx);
+ $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e;
+ $ret;
}
sub loop_common {
sub pp_trans {
my $self = shift;
- my($op, $cx) = @_;
+ my($op, $cx, $morflags) = @_;
my($from, $to);
my $class = class($op);
my $priv_flags = $op->private;
$flags .= "d" if $priv_flags & OPpTRANS_DELETE;
$to = "" if $from eq $to and $flags eq "";
$flags .= "s" if $priv_flags & OPpTRANS_SQUASH;
- return $self->keyword("tr") . double_delim($from, $to) . $flags;
+ $flags .= $morflags if defined $morflags;
+ my $ret = $self->keyword("tr") . double_delim($from, $to) . $flags;
+ if (my $targ = $op->targ) {
+ return $self->maybe_parens($self->padname($targ) . " =~ $ret",
+ $cx, 20);
+ }
+ return $ret;
}
-sub pp_transr { &pp_trans . 'r' }
+sub pp_transr { push @_, 'r'; goto &pp_trans }
sub re_dq_disambiguate {
my ($first, $last) = @_;
$var = $self->deparse($kid, 20);
$kid = $kid->sibling;
}
+ elsif ($name eq 'match' and my $targ = $op->targ) {
+ $binop = 1;
+ $var = $self->padname($targ);
+ }
my $quote = 1;
my $pmflags = $op->pmflags;
my $extended = ($pmflags & PMf_EXTENDED);
sub pp_runcv { unop(@_, "__SUB__"); }
sub pp_split {
+ maybe_targmy(@_, \&split);
+}
+sub split {
my $self = shift;
my($op, $cx) = @_;
my($kid, @exprs, $ary, $expr);
$var = $self->deparse($kid, 20);
$kid = $kid->sibling;
}
+ elsif (my $targ = $op->targ) {
+ $binop = 1;
+ $var = $self->padname($targ);
+ }
my $flags = "";
my $pmflags = $op->pmflags;
if (null($op->pmreplroot)) {
my ($self, $op, $cx) = @_;
my $left;
if ($op->private & OPpLVREF_ELEM) {
- $left = $op->first ->sibling ->first ->first;
- # rhs ex-srefgen ex-list ex-[ah]elem
+ $left = $op->first->sibling;
$left = maybe_local(@_, elem($self, $left, undef,
$left->targ == OP_AELEM
? qw([ ] padav)
=item *
-The only pragmas to be completely supported are: C<use warnings>,
+In Perl 5.20 and earlier, the only pragmas to
+be completely supported are: C<use warnings>,
C<use strict>, C<use bytes>, C<use integer>
and C<use feature>. (C<$[>, which
behaves like a pragma, is also supported.)
(such as by over-riding keywords, overloading constants or whatever)
then the output code might not work as intended.
-This is the most serious outstanding problem, and will require some help
-from the Perl core to fix.
+This is the most serious problem in Perl 5.20 and earlier. Fixing this
+required internal changes in Perl 5.22.
=item *
=item *
-Optimised away statements are rendered as
+Optimized-away statements are rendered as
'???'. This includes statements that
have a compile-time side-effect, such as the obscure
problem, as perl has no native facility for referring to a lexical variable
defined within a different scope, although L<PadWalker> is a good start.
+See also L<Data::Dump::Streamer>, which combines B::Deparse and
+L<PadWalker> to serialize closures properly.
+
=item *
There are probably many more bugs on non-ASCII platforms (EBCDIC).
use strict;
use Test::More;
-my $tests = 25; # not counting those in the __DATA__ section
+my $tests = 28; # not counting those in the __DATA__ section
use B::Deparse;
my $deparse = B::Deparse->new();
$a =~ s/-e syntax OK\n//g;
$a =~ s/.*possible typo.*\n//; # Remove warning line
$a =~ s/.*-i used with no filenames.*\n//; # Remove warning line
-$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
-$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
$b = quotemeta <<'EOF';
BEGIN { $^I = ".bak"; }
BEGIN { $^W = 1; }
like($a, qr/my sub __DATA__;\n\(\);\nCORE::__DATA__/,
'CORE::__DATA__ after my sub __DATA__');
+# sub declarations
+$a = readpipe qq`$^X $path "-MO=Deparse" -e "sub foo{}" 2>&1`;
+like($a, qr/sub foo\s*\{\s+\}/, 'sub declarations');
+
+# BEGIN blocks
+SKIP : {
+ skip "BEGIN output is wrong on old perls", 1 if $] < 5.021006;
+ my $prog = '
+ BEGIN { pop }
+ {
+ BEGIN { pop }
+ {
+ no overloading;
+ {
+ BEGIN { pop }
+ die
+ }
+ }
+ }';
+ $prog =~ s/\n//g;
+ $a = readpipe qq`$^X $path "-MO=Deparse" -e "$prog" 2>&1`;
+ $a =~ s/-e syntax OK\n//g;
+ is($a, <<'EOCODJ', 'BEGIN blocks');
+sub BEGIN {
+ pop @ARGV;
+}
+{
+ sub BEGIN {
+ pop @ARGV;
+ }
+ {
+ no overloading;
+ {
+ sub BEGIN {
+ pop @ARGV;
+ }
+ die;
+ }
+ }
+}
+EOCODJ
+}
+
+# [perl #115066]
+my $prog = 'use constant FOO => do { 1 }; no overloading; die';
+$a = readpipe qq`$^X $path "-MO=-qq,Deparse" -e "$prog" 2>&1`;
+is($a, <<'EOCODK', '[perl #115066] use statements accidentally nested');
+use constant ('FOO', do {
+ 1
+});
+no overloading;
+die;
+EOCODK
done_testing($tests);
# list x
-((1, 2) x 2);
####
+# Assignment to list x
+((undef) x 3) = undef;
+####
# lvalue sub
{
my $test = sub : lvalue {
;
}
####
+# anonsub attrs at statement start
+my $x = do { +sub : lvalue { my $y; } };
+my $z = do { foo: +sub : method { my $a; } };
+####
# block with continue
{
234;
# y///r
tr/a/b/r;
####
+# y///d in list [perl #119815]
+() = tr/a//d;
+####
# [perl #90898]
<a,>;
####
#@z = ($s7, undef, $s8);
($s7, undef, $s8) = (1, 2, 3);
####
-# anon lists with padrange
+# anon arrays with padrange
my($a, $b);
my $c = [$a, $b];
my $d = {$a, $b};
=head1 DESCRIPTION
-This module provides three global hashes:
+This module provides four global hashes:
%B::Op_private::bits
%B::Op_private::defines
%B::Op_private::labels
+ %B::Op_private::ops_using
which contain information about the per-op meanings of the bits in the
op_private field.
If the label equals '-', then Concise will treat the bit as a raw bit and
not try to display it symbolically.
+=head2 C<%ops_using>
+
+For each define, this gives a reference to an array of op names that use
+the flag.
+
+ @ops_using_lvintro = @{ $B::Op_private::ops_using{OPp_LVAL_INTRO} };
+
=cut
package B::Op_private;
our %bits;
-our $VERSION = "5.021005";
+our $VERSION = "5.021006";
$bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv);
-$bits{$_}{4} = 'OPpENTERSUB_DB' for qw(entersub rv2cv);
+$bits{$_}{6} = '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{$_}{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{$_}{6} = 'OPpLVAL_DEFER' for qw(aelem helem);
$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv);
$bits{$_}{2} = 'OPpLVREF_ELEM' for qw(lvref refassign);
$bits{$_}{3} = 'OPpLVREF_ITER' for qw(lvref refassign);
$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{$_}{4} = '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 split);
-$bits{$_}{4} = 'OPpPAD_STATE' for qw(lvavref lvref padav padhv padsv pushmark refassign);
+$bits{$_}{6} = 'OPpOUR_INTRO' for qw(enteriter gvsv rv2av rv2hv rv2sv split);
+$bits{$_}{6} = 'OPpPAD_STATE' for qw(lvavref lvref padav padhv padsv pushmark refassign);
$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{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log match mkdir modulo multiply oct ord pow push rand rename repeat right_shift rindex rmdir schomp setpgrp setpriority sin sleep split sqrt srand stringify subst subtract symlink system time trans transr unlink unshift utime vec 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);
},
{
mask_def => 'OPpDEREF',
- bitmin => 5,
- bitmax => 6,
- bitmask => 96,
+ bitmin => 4,
+ bitmax => 5,
+ bitmask => 48,
enum => [
1, 'OPpDEREF_AV', 'DREFAV',
2, 'OPpDEREF_HV', 'DREFHV',
},
{
mask_def => 'OPpLVREF_TYPE',
- bitmin => 5,
- bitmax => 6,
- bitmask => 96,
+ bitmin => 4,
+ bitmax => 5,
+ bitmask => 48,
enum => [
0, 'OPpLVREF_SV', 'SV',
1, 'OPpLVREF_AV', 'AV',
@{$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{aelem}}{5,4,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{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{entersub}}{5,4,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{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{helem}}{5,4,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{lstat}{0} = $bf[0];
@{$bits{lt}}{1,0} = ($bf[1], $bf[1]);
$bits{lvavref}{0} = $bf[0];
-@{$bits{lvref}}{6,5,0} = ($bf[7], $bf[7], $bf[0]);
+@{$bits{lvref}}{5,4,0} = ($bf[7], $bf[7], $bf[0]);
$bits{mapwhile}{0} = $bf[0];
$bits{method}{0} = $bf[0];
$bits{method_named}{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{padsv}}{5,4} = ($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{recv}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]);
$bits{redo}{0} = $bf[0];
$bits{ref}{0} = $bf[0];
-@{$bits{refassign}}{6,5,1,0} = ($bf[7], $bf[7], $bf[1], $bf[1]);
+@{$bits{refassign}}{5,4,1,0} = ($bf[7], $bf[7], $bf[1], $bf[1]);
$bits{refgen}{0} = $bf[0];
$bits{regcmaybe}{0} = $bf[0];
$bits{regcomp}{0} = $bf[0];
$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{rv2cv}}{7,5,0} = ('OPpENTERSUB_NOPAREN', 'OPpMAY_RETURN_CONSTANT', $bf[0]);
+@{$bits{rv2gv}}{6,5,4,2,0} = ('OPpALLOW_FAKE', $bf[6], $bf[6], 'OPpDONT_INIT_GV', $bf[0]);
$bits{rv2hv}{0} = $bf[0];
-@{$bits{rv2sv}}{6,5,0} = ($bf[6], $bf[6], $bf[0]);
+@{$bits{rv2sv}}{5,4,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];
our %defines = (
- OPpALLOW_FAKE => 16,
+ OPpALLOW_FAKE => 64,
OPpARG1_MASK => 1,
OPpARG2_MASK => 3,
OPpARG3_MASK => 7,
OPpCOREARGS_DEREF2 => 2,
OPpCOREARGS_PUSHMARK => 128,
OPpCOREARGS_SCALARMOD => 64,
- OPpDEREF => 96,
- OPpDEREF_AV => 32,
- OPpDEREF_HV => 64,
- OPpDEREF_SV => 96,
+ OPpDEREF => 48,
+ OPpDEREF_AV => 16,
+ OPpDEREF_HV => 32,
+ OPpDEREF_SV => 48,
OPpDONT_INIT_GV => 4,
OPpEARLY_CV => 32,
OPpENTERSUB_AMPER => 8,
- OPpENTERSUB_DB => 16,
+ OPpENTERSUB_DB => 64,
OPpENTERSUB_HASTARG => 4,
OPpENTERSUB_INARGS => 1,
OPpENTERSUB_NOPAREN => 128,
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_DEFER => 64,
OPpLVAL_INTRO => 128,
- OPpLVREF_AV => 32,
- OPpLVREF_CV => 96,
+ OPpLVREF_AV => 16,
+ OPpLVREF_CV => 48,
OPpLVREF_ELEM => 4,
- OPpLVREF_HV => 64,
+ OPpLVREF_HV => 32,
OPpLVREF_ITER => 8,
OPpLVREF_SV => 0,
- OPpLVREF_TYPE => 96,
+ OPpLVREF_TYPE => 48,
OPpMAYBE_LVSUB => 8,
- OPpMAYBE_TRUEBOOL => 64,
- OPpMAY_RETURN_CONSTANT => 64,
+ OPpMAYBE_TRUEBOOL => 16,
+ OPpMAY_RETURN_CONSTANT => 32,
OPpOFFBYONE => 128,
OPpOPEN_IN_CRLF => 32,
OPpOPEN_IN_RAW => 16,
OPpOPEN_OUT_CRLF => 128,
OPpOPEN_OUT_RAW => 64,
- OPpOUR_INTRO => 16,
+ OPpOUR_INTRO => 64,
OPpPADRANGE_COUNTMASK => 127,
OPpPADRANGE_COUNTSHIFT => 7,
- OPpPAD_STATE => 16,
+ OPpPAD_STATE => 64,
OPpPV_IS_UTF8 => 128,
OPpREFCOUNTED => 64,
OPpREPEAT_DOLIST => 64,
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',
OPpTRUEBOOL => 'BOOL',
);
+
+our %ops_using = (
+ OPpALLOW_FAKE => [qw(rv2gv)],
+ OPpASSIGN_BACKWARDS => [qw(sassign)],
+ OPpASSIGN_COMMON => [qw(aassign)],
+ OPpCONST_BARE => [qw(const)],
+ OPpCOREARGS_DEREF1 => [qw(coreargs)],
+ OPpEARLY_CV => [qw(gv)],
+ OPpENTERSUB_AMPER => [qw(entersub rv2cv)],
+ OPpENTERSUB_INARGS => [qw(entersub)],
+ OPpENTERSUB_NOPAREN => [qw(rv2cv)],
+ OPpEVAL_BYTES => [qw(entereval)],
+ OPpEXISTS_SUB => [qw(exists)],
+ OPpFLIP_LINENUM => [qw(flip flop)],
+ OPpFT_ACCESS => [qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite)],
+ OPpFT_AFTER_t => [qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero)],
+ OPpGREP_LEX => [qw(grepstart grepwhile mapstart mapwhile)],
+ OPpHINT_STRICT_REFS => [qw(entersub rv2av rv2cv rv2gv rv2hv rv2sv)],
+ OPpHUSH_VMSISH => [qw(dbstate nextstate)],
+ OPpITER_DEF => [qw(enteriter)],
+ OPpITER_REVERSED => [qw(enteriter iter)],
+ OPpLIST_GUESSED => [qw(list)],
+ OPpLVALUE => [qw(leave leaveloop)],
+ OPpLVAL_DEFER => [qw(aelem helem)],
+ OPpLVAL_INTRO => [qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv)],
+ OPpLVREF_ELEM => [qw(lvref refassign)],
+ OPpMAYBE_LVSUB => [qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice padav padhv pos rkeys rv2av rv2gv rv2hv substr vec)],
+ OPpMAYBE_TRUEBOOL => [qw(padhv rv2hv)],
+ OPpOFFBYONE => [qw(caller runcv wantarray)],
+ OPpOPEN_IN_CRLF => [qw(backtick open)],
+ OPpOUR_INTRO => [qw(enteriter gvsv rv2av rv2hv rv2sv split)],
+ OPpPAD_STATE => [qw(lvavref lvref padav padhv padsv pushmark refassign)],
+ OPpPV_IS_UTF8 => [qw(dump goto last next redo)],
+ OPpREFCOUNTED => [qw(leave leaveeval leavesub leavesublv leavewrite)],
+ OPpREPEAT_DOLIST => [qw(repeat)],
+ OPpREVERSE_INPLACE => [qw(reverse)],
+ OPpRUNTIME => [qw(match pushre qr subst substcont)],
+ OPpSLICE => [qw(delete)],
+ OPpSLICEWARNING => [qw(aslice hslice padav padhv rv2av rv2hv)],
+ OPpSORT_DESCEND => [qw(sort)],
+ OPpSPLIT_IMPLIM => [qw(split)],
+ OPpSUBSTR_REPL_FIRST => [qw(substr)],
+ OPpTARGET_MY => [qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log match mkdir modulo multiply oct ord pow push rand rename repeat right_shift rindex rmdir schomp setpgrp setpriority sin sleep split sqrt srand stringify subst subtract symlink system time trans transr unlink unshift utime vec wait waitpid)],
+ OPpTRANS_COMPLEMENT => [qw(trans transr)],
+);
+
+$ops_using{OPpASSIGN_CV_TO_GV} = $ops_using{OPpASSIGN_BACKWARDS};
+$ops_using{OPpCONST_ENTERED} = $ops_using{OPpCONST_BARE};
+$ops_using{OPpCONST_NOVER} = $ops_using{OPpCONST_BARE};
+$ops_using{OPpCONST_SHORTCIRCUIT} = $ops_using{OPpCONST_BARE};
+$ops_using{OPpCONST_STRICT} = $ops_using{OPpCONST_BARE};
+$ops_using{OPpCOREARGS_DEREF2} = $ops_using{OPpCOREARGS_DEREF1};
+$ops_using{OPpCOREARGS_PUSHMARK} = $ops_using{OPpCOREARGS_DEREF1};
+$ops_using{OPpCOREARGS_SCALARMOD} = $ops_using{OPpCOREARGS_DEREF1};
+$ops_using{OPpDONT_INIT_GV} = $ops_using{OPpALLOW_FAKE};
+$ops_using{OPpENTERSUB_DB} = $ops_using{OPpENTERSUB_AMPER};
+$ops_using{OPpENTERSUB_HASTARG} = $ops_using{OPpENTERSUB_AMPER};
+$ops_using{OPpEVAL_COPHH} = $ops_using{OPpEVAL_BYTES};
+$ops_using{OPpEVAL_HAS_HH} = $ops_using{OPpEVAL_BYTES};
+$ops_using{OPpEVAL_RE_REPARSING} = $ops_using{OPpEVAL_BYTES};
+$ops_using{OPpEVAL_UNICODE} = $ops_using{OPpEVAL_BYTES};
+$ops_using{OPpFT_STACKED} = $ops_using{OPpFT_AFTER_t};
+$ops_using{OPpFT_STACKING} = $ops_using{OPpFT_AFTER_t};
+$ops_using{OPpLVREF_ITER} = $ops_using{OPpLVREF_ELEM};
+$ops_using{OPpMAY_RETURN_CONSTANT} = $ops_using{OPpENTERSUB_NOPAREN};
+$ops_using{OPpOPEN_IN_RAW} = $ops_using{OPpOPEN_IN_CRLF};
+$ops_using{OPpOPEN_OUT_CRLF} = $ops_using{OPpOPEN_IN_CRLF};
+$ops_using{OPpOPEN_OUT_RAW} = $ops_using{OPpOPEN_IN_CRLF};
+$ops_using{OPpSORT_INPLACE} = $ops_using{OPpSORT_DESCEND};
+$ops_using{OPpSORT_INTEGER} = $ops_using{OPpSORT_DESCEND};
+$ops_using{OPpSORT_NUMERIC} = $ops_using{OPpSORT_DESCEND};
+$ops_using{OPpSORT_QSORT} = $ops_using{OPpSORT_DESCEND};
+$ops_using{OPpSORT_REVERSE} = $ops_using{OPpSORT_DESCEND};
+$ops_using{OPpSORT_STABLE} = $ops_using{OPpSORT_DESCEND};
+$ops_using{OPpTRANS_DELETE} = $ops_using{OPpTRANS_COMPLEMENT};
+$ops_using{OPpTRANS_FROM_UTF} = $ops_using{OPpTRANS_COMPLEMENT};
+$ops_using{OPpTRANS_GROWS} = $ops_using{OPpTRANS_COMPLEMENT};
+$ops_using{OPpTRANS_IDENTICAL} = $ops_using{OPpTRANS_COMPLEMENT};
+$ops_using{OPpTRANS_SQUASH} = $ops_using{OPpTRANS_COMPLEMENT};
+$ops_using{OPpTRANS_TO_UTF} = $ops_using{OPpTRANS_COMPLEMENT};
+$ops_using{OPpTRUEBOOL} = $ops_using{OPpMAYBE_TRUEBOOL};
+
# ex: set ro:
no warnings 'surrogate'; # surrogates can be inputs to this
use charnames ();
-our $VERSION = '0.58';
+our $VERSION = '0.59';
require Exporter;
If supplied with an argument that can't be a code point, C<charblock()> tries to
do the opposite and interpret the argument as an old-style block name. On an
ASCII platform, the return value is a I<range set> with one range: an
-anonymous list with a single element that consists of another anonymous list
+anonymous array with a single element that consists of another anonymous array
whose first element is the first code point in the block, and whose second
element is the final code point in the block. On an EBCDIC
platform, the first two Unicode blocks are not contiguous. Their range sets
If supplied with an argument that can't be a code point, charscript() tries
to do the opposite and interpret the argument as a script name. The
-return value is a I<range set>: an anonymous list of lists that contain
+return value is a I<range set>: an anonymous array of arrays that contain
I<start-of-range>, I<end-of-range> code point pairs. You can test whether a
code point is in a range set using the L</charinrange()> function.
(To be precise, each I<range set> contains a third array element,
package locale;
-our $VERSION = '1.04';
+our $VERSION = '1.05';
use Config;
$Carp::Internal{ (__PACKAGE__) } = 1;
# The list of test numbers of the problematic tests.
my %problematical_tests;
+# If any %problematical_tests fails in one of these locales, it is
+# considered a TODO.
+my %known_bad_locales = (
+ irix => qr/ ^ (?: cs | hu | sk ) $/x,
+ darwin => qr/ ^ lt_LT.ISO8859 /ix,
+ os390 => qr/ ^ italian /ix,
+ );
use Dumpvalue;
return unless $debug;
my($mess) = join "", '# ', @_;
chop $mess;
- print $dumper->stringify($mess,1), "\n";
+ print STDERR $dumper->stringify($mess,1), "\n";
}
sub debug_more {
}
sub debugf {
- printf @_ if $debug;
+ printf STDERR @_ if $debug;
}
$a = 'abc %9';
require POSIX; import POSIX ':locale_h';
+no warnings 'locale'; # We test even weird locales;
+
my @Locale = find_locales([ &POSIX::LC_CTYPE, &POSIX::LC_NUMERIC, &POSIX::LC_ALL ]);
debug "Locales =\n";
my %Problem;
my %Okay;
+my %Known_bad_locale; # Failed test for a locale known to be bad
my %Testing;
my @Added_alpha; # Alphas that aren't in the C locale.
my %test_names;
my ($Locale, $i, $pass_fail, $message) = @_;
$message //= "";
$message = " ($message)" if $message;
- unless ($pass_fail) {
+ if ($pass_fail) {
+ push @{$Okay{$i}}, $Locale;
+ }
+ else {
+ $Known_bad_locale{$i}{$Locale} = 1 if exists $known_bad_locales{$^O}
+ && $Locale =~ $known_bad_locales{$^O};
$Problem{$i}{$Locale} = 1;
debug "failed $i ($test_names{$i}) with locale '$Locale'$message\n";
- } else {
- push @{$Okay{$i}}, $Locale;
}
}
"; lc=", disp_chars(($y)), "; ",
"; fc=", disp_chars((fc $x)), "; ",
disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
- $x =~ /$y/i ? 1 : 0,
+ $x =~ /\Q$y/i ? 1 : 0,
"; ",
disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
- $y =~ /$x/i ? 1 : 0,
+ $y =~ /\Q$x/i ? 1 : 0,
"\n");
#
# If $x and $y contain regular expression characters
print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
next;
}
- push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
+ push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
# fc is not a locale concept, so Perl uses lc for it.
push @f, $x unless lc $x eq fc $x;
"; lc=", disp_chars(($y)), "; ",
"; fc=", disp_chars((fc $x)), "; ",
disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
- $x =~ /$y/i ? 1 : 0,
+ $x =~ /\Q$y/i ? 1 : 0,
"; ",
disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
- $y =~ /$x/i ? 1 : 0,
+ $y =~ /\Q$x/i ? 1 : 0,
"\n");
- push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
+ push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
# The places where Unicode's lc is different from fc are
# skipped here by virtue of the 'next unless uc...' line above
"; uc=", disp_chars(($y)), "; ",
"; fc=", disp_chars((fc $x)), "; ",
disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
- $x =~ /$y/i ? 1 : 0,
+ $x =~ /\Q$y/i ? 1 : 0,
"; ",
disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
- $y =~ /$x/i ? 1 : 0,
+ $y =~ /\Q$x/i ? 1 : 0,
"\n");
if ($x =~ $re || $y =~ $re) { # See above.
print "# Regex characters in '$x' or '$y', skipping test $locales_test_number for locale '$Locale'\n";
next;
}
- push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
+ push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
push @f, $x unless lc $x eq fc $x;
}
"; uc=", disp_chars(($y)), "; ",
"; fc=", disp_chars((fc $x)), "; ",
disp_chars(($x)), "=~/", disp_chars(($y)), "/i=",
- $x =~ /$y/i ? 1 : 0,
+ $x =~ /\Q$y/i ? 1 : 0,
"; ",
disp_chars(($y)), "=~/", disp_chars(($x)), "/i=",
- $y =~ /$x/i ? 1 : 0,
+ $y =~ /\Q$x/i ? 1 : 0,
"\n");
- push @f, $x unless $x =~ /$y/i && $y =~ /$x/i;
+ push @f, $x unless $x =~ /\Q$y/i && $y =~ /\Q$x/i;
push @f, $x unless lc $x eq fc $x;
}
# Recount the errors.
+TEST_NUM:
foreach $test_num ($first_locales_test_number..$final_locales_test_number) {
if (%setlocale_failed) {
print "not ";
}
- elsif ($Problem{$test_num} || !defined $Okay{$test_num} || !@{$Okay{$test_num}}) {
+ elsif ($Problem{$test_num}
+ || ! defined $Okay{$test_num}
+ || ! @{$Okay{$test_num}})
+ {
if (defined $not_necessarily_a_problem_test_number
&& $test_num == $not_necessarily_a_problem_test_number)
{
print "# It usually indicates a problem in the environment,\n";
print "# not in Perl itself.\n";
}
- if ($Okay{$test_num} && grep { $_ == $test_num } keys %problematical_tests) {
+
+ # If there are any locales that pass this test, or are known-bad, it
+ # may be that there are enough passes that we TODO the failure.
+ if (($Okay{$test_num} || $Known_bad_locale{$test_num})
+ && grep { $_ == $test_num } keys %problematical_tests)
+ {
no warnings 'experimental::autoderef';
+
+ # Don't count the known-bad failures when calculating the
+ # percentage that fail.
+ my $known_failures = (exists $Known_bad_locale{$test_num})
+ ? scalar(keys $Known_bad_locale{$test_num})
+ : 0;
+ my $adjusted_failures = scalar(keys $Problem{$test_num})
+ - $known_failures;
+
+ # Specially handle failures where only known-bad locales fail.
+ # This makes the diagnositics clearer.
+ if ($adjusted_failures <= 0) {
+ print "not ok $test_num $test_names{$test_num} # TODO fails only on ",
+ "known bad locales: ",
+ join " ", keys $Known_bad_locale{$test_num}, "\n";
+ next TEST_NUM;
+ }
+
# Round to nearest .1%
- my $percent_fail = (int(.5 + (1000 * scalar(keys $Problem{$test_num})
+ my $percent_fail = (int(.5 + (1000 * $adjusted_failures
/ scalar(@Locale))))
/ 10;
if ($percent_fail < $acceptable_failure_percentage) {
if (! $debug) {
$test_names{$test_num} .= 'TODO';
- print "# ", 100 - $percent_fail, "% of locales pass the following test, so it is likely that the failures\n";
+ print "# ", 100 - $percent_fail, "% of locales not known to be problematic on this platform\n";
+ print "# pass the following test, so it is likely that the failures\n";
print "# are errors in the locale definitions. The test is marked TODO, as the\n";
print "# problem is not likely to be Perl's\n";
}
my $should_be;
my $changed;
if (! $is_utf8_locale) {
+ no warnings 'locale';
$should_be = ($j == $#list)
? chr(ord($char) + $above_latin1_case_change_delta)
: (length $char == 0 || ord($char) > 127)
foreach ($first_locales_test_number..$final_locales_test_number) {
if ($Problem{$_}) {
my @f = sort keys %{ $Problem{$_} };
+
+ # Don't list the failures caused by known-bad locales.
+ if (exists $known_bad_locales{$^O}) {
+ @f = grep { $_ !~ $known_bad_locales{$^O} } @f;
+ next unless @f;
+ }
my $f = join(" ", @f);
$f =~ s/(.{50,60}) /$1\n#\t/g;
print
}
}
+if (exists $known_bad_locales{$^O} && ! %Known_bad_locale) {
+ $test_num++;
+ print "ok $test_num $^O no longer has known bad locales # TODO\n";
+}
+
print "1..$test_num\n";
# eof
package overload;
-our $VERSION = '1.23';
+our $VERSION = '1.24';
%ops = (
with_assign => "+ - * / % ** << >> x .",
sub OVERLOAD {
$package = shift;
my %arg = @_;
- my ($sub, $fb);
+ my $sub;
*{$package . "::(("} = \&nil; # Make it findable via fetchmethod.
for (keys %arg) {
if ($_ eq 'fallback') {
$| = 1;
BEGIN { require './test.pl' }
-plan tests => 5198;
+plan tests => 5199;
use Scalar::Util qw(tainted);
is ioref->(), 46, '(overloaded constant that is not a sub ref)->()';
}
+package xstack { use overload 'x' => sub { shift . " x " . shift },
+ '""'=> sub { "xstack" } }
+is join(",", 1..3, scalar((bless([], 'xstack')) x 3, 1), 4..6),
+ "1,2,3,1,4,5,6",
+ '(...)x... in void cx with x overloaded [perl #121827]';
+
{ # undefining the overload stash -- KEEP THIS TEST LAST
package ant;
use overload '+' => 'onion';
0844; MANDAIC AH; D; No_Joining_Group
0845; MANDAIC USHENNA; D; No_Joining_Group
0846; MANDAIC AZ; R; No_Joining_Group
-0847; MANDAIC IT; D; No_Joining_Group
+0847; MANDAIC IT; R; No_Joining_Group
0848; MANDAIC ATT; D; No_Joining_Group
0849; MANDAIC AKSA; R; No_Joining_Group
084A; MANDAIC AK; D; No_Joining_Group
084C; MANDAIC AM; D; No_Joining_Group
084D; MANDAIC AN; D; No_Joining_Group
084E; MANDAIC AS; D; No_Joining_Group
-084F; MANDAIC IN; R; No_Joining_Group
+084F; MANDAIC IN; D; No_Joining_Group
0850; MANDAIC AP; D; No_Joining_Group
0851; MANDAIC ASZ; D; No_Joining_Group
0852; MANDAIC AQ; D; No_Joining_Group
}
}
- # I (khw) have never waded through this line to
- # understand it well enough to comment it.
+ # The unpack yields a list of the bytes that comprise the
+ # UTF-8 of $code_point, which are each placed in \xZZ format
+ # and output in the %s to map to $tostr, so the result looks
+ # like:
+ # "\xC4\xB0" => "\x{0069}\x{0307}",
my $utf8 = sprintf(qq["%s" => "$tostr",],
join("", map { sprintf "\\x%02X", $_ }
- unpack("U0C*", pack("U", $code_point))));
+ unpack("U0C*", chr $code_point)));
# Add a comment so that a human reader can more easily
# see what's going on.
package warnings;
-our $VERSION = '1.28';
+our $VERSION = '1.29';
# Verify that we're called correctly so that warnings will work.
# see also strict.pm.
'experimental::refaliasing'=> 120,
'experimental::win32_perlio'=> 122,
- 'missing' => 124,
- 'redundant' => 126,
+ 'locale' => 124,
+ 'missing' => 126,
+ 'redundant' => 128,
);
our %Bits = (
- 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..63]
- 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [29]
- 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [30]
- 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
- 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
- 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
- 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
- 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [31]
- 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
- 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
- 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x15\x05", # [51..58,60,61]
- 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [56]
- 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [52]
- 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [53]
- 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [57]
- 'experimental::refaliasing'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [60]
- 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [54]
- 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [58]
- 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [55]
- 'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [61]
- 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
- 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [47]
- 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [46]
- 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
- 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24]
- 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [5..11,59]
- 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
- 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25]
- 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
- 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [62]
- 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
- 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [48]
- 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [49]
- 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
- 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
- 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
- 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
- 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [32]
- 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
- 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
- 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [33]
- 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [34]
- 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [35]
- 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [36]
- 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
- 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
- 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [63]
- 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
- 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [37]
- 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [38]
- 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25]
- 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [26]
- 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27]
- 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [50]
- 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00\x00\x00", # [28..38,47]
- 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [59]
- 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [39]
- 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [40]
- 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [41]
- 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
- 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [42]
- 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [43]
- 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00\x00\x00", # [44,48..50]
- 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [45]
+ 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x01", # [0..64]
+ 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [29]
+ 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [30]
+ 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
+ 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
+ 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
+ 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
+ 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31]
+ 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
+ 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x15\x05\x00", # [51..58,60,61]
+ 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [56]
+ 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [52]
+ 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [53]
+ 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [57]
+ 'experimental::refaliasing'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [60]
+ 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [54]
+ 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [58]
+ 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [55]
+ 'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [61]
+ 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+ 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [47]
+ 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [46]
+ 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
+ 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24]
+ 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [5..11,59]
+ 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
+ 'locale' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [62]
+ 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25]
+ 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
+ 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [63]
+ 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
+ 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [48]
+ 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [49]
+ 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
+ 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
+ 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
+ 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
+ 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [32]
+ 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
+ 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
+ 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [33]
+ 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [34]
+ 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [35]
+ 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [36]
+ 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
+ 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
+ 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [64]
+ 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
+ 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [37]
+ 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [38]
+ 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25]
+ 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [26]
+ 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27]
+ 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [50]
+ 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00\x00\x00\x00", # [28..38,47]
+ 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [59]
+ 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [39]
+ 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [40]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [41]
+ 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
+ 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [42]
+ 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [43]
+ 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00\x00\x00\x00", # [44,48..50]
+ 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [45]
);
our %DeadBits = (
- 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..63]
- 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [29]
- 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [30]
- 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
- 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
- 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
- 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
- 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [31]
- 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
- 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
- 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\x2a\x0a", # [51..58,60,61]
- 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [56]
- 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [52]
- 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [53]
- 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [57]
- 'experimental::refaliasing'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [60]
- 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [54]
- 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [58]
- 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [55]
- 'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [61]
- 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
- 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [47]
- 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [46]
- 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
- 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24]
- 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [5..11,59]
- 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
- 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25]
- 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
- 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [62]
- 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
- 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [48]
- 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [49]
- 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
- 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
- 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
- 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
- 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [32]
- 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
- 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
- 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [33]
- 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [34]
- 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [35]
- 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [36]
- 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
- 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
- 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [63]
- 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
- 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [37]
- 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [38]
- 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25]
- 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [26]
- 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27]
- 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [50]
- 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00\x00\x00", # [28..38,47]
- 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [59]
- 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [39]
- 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [40]
- 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [41]
- 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
- 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [42]
- 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [43]
- 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00\x00\x00", # [44,48..50]
- 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [45]
+ 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x02", # [0..64]
+ 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [29]
+ 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [30]
+ 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
+ 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
+ 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
+ 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
+ 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31]
+ 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
+ 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\x2a\x0a\x00", # [51..58,60,61]
+ 'experimental::autoderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [56]
+ 'experimental::lexical_subs'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [52]
+ 'experimental::lexical_topic'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [53]
+ 'experimental::postderef'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [57]
+ 'experimental::refaliasing'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [60]
+ 'experimental::regex_sets'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [54]
+ 'experimental::signatures'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [58]
+ 'experimental::smartmatch'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [55]
+ 'experimental::win32_perlio'=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [61]
+ 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+ 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [47]
+ 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [46]
+ 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23]
+ 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24]
+ 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [5..11,59]
+ 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
+ 'locale' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [62]
+ 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25]
+ 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
+ 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [63]
+ 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
+ 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [48]
+ 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [49]
+ 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
+ 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
+ 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
+ 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
+ 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [32]
+ 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
+ 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
+ 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [33]
+ 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [34]
+ 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [35]
+ 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [36]
+ 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
+ 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
+ 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [64]
+ 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20]
+ 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [37]
+ 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [38]
+ 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25]
+ 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [26]
+ 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27]
+ 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [50]
+ 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00\x00\x00\x00", # [28..38,47]
+ 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [59]
+ 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [39]
+ 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [40]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [41]
+ 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
+ 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [42]
+ 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [43]
+ 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00\x00\x00\x00", # [44,48..50]
+ 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [45]
);
-$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
-$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x15\x05", # [2,56,52,53,57,60,54,58,55,61,4,22,23,25]
-$LAST_BIT = 128 ;
-$BYTES = 16 ;
+$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
+$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x15\x15\x00", # [2,56,52,53,57,60,54,58,55,61,4,62,22,23,25]
+$LAST_BIT = 130 ;
+$BYTES = 17 ;
$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
| |
| +- unopened
|
+ +- locale
+ |
+- misc
|
+- missing
Copy(PL_fold_latin1, PL_fold_locale, 256, U8);
}
else {
+ /* Assume enough space for every character being bad. 4 spaces each
+ * for the 94 printable characters that are output like "'x' "; and 5
+ * spaces each for "'\\' ", "'\t' ", and "'\n' "; plus a terminating
+ * NUL */
+ char bad_chars_list[ (94 * 4) + (3 * 5) + 1 ];
+
+ bool check_for_problems = ckWARN_d(WARN_LOCALE); /* No warnings means
+ no check */
+ bool multi_byte_locale = FALSE; /* Assume is a single-byte locale
+ to start */
+ unsigned int bad_count = 0; /* Count of bad characters */
+
for (i = 0; i < 256; i++) {
if (isUPPER_LC((U8) i))
PL_fold_locale[i] = (U8) toLOWER_LC((U8) i);
PL_fold_locale[i] = (U8) toUPPER_LC((U8) i);
else
PL_fold_locale[i] = (U8) i;
+
+ /* If checking for locale problems, see if the native ASCII-range
+ * printables plus \n and \t are in their expected categories in
+ * the new locale. If not, this could mean big trouble, upending
+ * Perl's and most programs' assumptions, like having a
+ * metacharacter with special meaning become a \w. Fortunately,
+ * it's very rare to find locales that aren't supersets of ASCII
+ * nowadays. It isn't a problem for most controls to be changed
+ * into something else; we check only \n and \t, though perhaps \r
+ * could be an issue as well. */
+ if (check_for_problems
+ && (isGRAPH_A(i) || isBLANK_A(i) || i == '\n'))
+ {
+ if ((isALPHANUMERIC_A(i) && ! isALPHANUMERIC_LC(i))
+ || (isPUNCT_A(i) && ! isPUNCT_LC(i))
+ || (isBLANK_A(i) && ! isBLANK_LC(i))
+ || (i == '\n' && ! isCNTRL_LC(i)))
+ {
+ if (bad_count) { /* Separate multiple entries with a
+ blank */
+ bad_chars_list[bad_count++] = ' ';
+ }
+ bad_chars_list[bad_count++] = '\'';
+ if (isPRINT_A(i)) {
+ bad_chars_list[bad_count++] = (char) i;
+ }
+ else {
+ bad_chars_list[bad_count++] = '\\';
+ if (i == '\n') {
+ bad_chars_list[bad_count++] = 'n';
+ }
+ else {
+ assert(i == '\t');
+ bad_chars_list[bad_count++] = 't';
+ }
+ }
+ bad_chars_list[bad_count++] = '\'';
+ bad_chars_list[bad_count] = '\0';
+ }
+ }
+ }
+
+#ifdef MB_CUR_MAX
+ /* We only handle single-byte locales (outside of UTF-8 ones; so if
+ * this locale requires than one byte, there are going to be
+ * problems. */
+ if (check_for_problems && MB_CUR_MAX > 1) {
+ multi_byte_locale = TRUE;
+ }
+#endif
+
+ if (bad_count || multi_byte_locale) {
+
+ /* We have to save 'newctype' because the setlocale() just below
+ * may destroy it. The next setlocale() further down should
+ * restore it properly so that the intermediate change here is
+ * transparent to this function's caller */
+ const char * const badlocale = savepv(newctype);
+
+ setlocale(LC_CTYPE, "C");
+ Perl_warner(aTHX_ packWARN(WARN_LOCALE),
+ "Locale '%s' may not work well.%s%s%s\n",
+ badlocale,
+ (multi_byte_locale)
+ ? " Some characters in it are not recognized by"
+ " Perl."
+ : "",
+ (bad_count)
+ ? "\nThe following characters (and maybe others)"
+ " may not have the same meaning as the Perl"
+ " program expects:\n"
+ : "",
+ (bad_count)
+ ? bad_chars_list
+ : ""
+ );
+ setlocale(LC_CTYPE, badlocale);
}
}
|| wc != (wchar_t) 0x2010)
{
is_utf8 = FALSE;
- DEBUG_L(PerlIO_printf(Perl_debug_log, "\thyphen=U+%x\n", wc));
+ DEBUG_L(PerlIO_printf(Perl_debug_log, "\thyphen=U+%x\n", (unsigned int)wc));
DEBUG_L(PerlIO_printf(Perl_debug_log,
"\treturn from mbtowc=%d; errno=%d; ?UTF8 locale=0\n",
mbtowc(&wc, HYPHEN_UTF8, strlen(HYPHEN_UTF8)), errno));
#endif /* the code that is compiled when no nl_langinfo */
+#ifndef EBCDIC /* On os390, even if the name ends with "UTF-8', it isn't a
+ UTF-8 locale */
/* As a last resort, look at the locale name to see if it matches
* qr/UTF -? * 8 /ix, or some other common locale names. This "name", the
* return of setlocale(), is actually defined to be opaque, so we can't
"Locale %s doesn't end with UTF-8 in name\n",
save_input_locale));
}
+#endif
#ifdef WIN32
/* http://msdn.microsoft.com/en-us/library/windows/desktop/dd317756.aspx */
use strict;
use warnings;
use Config;
-use constant IS_CROSS => defined $Config::Config{usecrosscompile} ? 1 : 0;
-
-my $is_Win32 = $^O eq 'MSWin32';
-my $is_VMS = $^O eq 'VMS';
-my $is_Unix = !$is_Win32 && !$is_VMS;
+use constant{IS_CROSS => defined $Config::Config{usecrosscompile} ? 1 : 0,
+ IS_WIN32 => $^O eq 'MSWin32',
+ IS_VMS => $^O eq 'VMS',
+ IS_UNIX => $^O ne 'MSWin32' && $^O ne 'VMS',
+};
my @ext_dirs = qw(cpan dist ext);
my $ext_dirs_re = '(?:' . join('|', @ext_dirs) . ')';
my $perl;
my %extra_passthrough;
-if ($is_Win32) {
+if (IS_WIN32) {
require Cwd;
require FindExt;
my $build = Cwd::getcwd();
next;
}
push @extspec, $_;
- if($_ eq 'DynaLoader' and $target !~ /clean$/) {
- # No, we don't know why nmake can't work out the dependency chain
- push @{$extra_passthrough{$_}}, 'DynaLoader.c';
- } elsif(FindExt::is_static($_)) {
+ if($_ ne 'DynaLoader' && FindExt::is_static($_)) {
push @{$extra_passthrough{$_}}, 'LINKTYPE=static';
}
}
chdir '..'
or die "Couldn't chdir to build directory: $!"; # now in the Perl build
}
-elsif ($is_VMS) {
+elsif (IS_VMS) {
$perl = $^X;
push @extspec, (split ' ', $Config{static_ext}) if $static;
push @extspec, (split ' ', $Config{dynamic_ext}) if $dynamic;
my $lib_dir = "$up/lib";
$ENV{PERL_CORE} = 1;
- my $makefile;
- if ($is_VMS) {
+ my ($makefile, $makefile_no_minus_f);
+ if (IS_VMS) {
$makefile = 'descrip.mms';
if ($target =~ /clean$/
&& !-f $makefile
}
if (-f $makefile) {
+ $makefile_no_minus_f = 0;
open my $mfh, $makefile or die "Cannot open $makefile: $!";
while (<$mfh>) {
# Plagiarised from CPAN::Distribution
_unlink($makefile);
}
}
+ } else {
+ $makefile_no_minus_f = 1;
}
- if (!-f $makefile) {
+ if ($makefile_no_minus_f || !-f $makefile) {
NO_MAKEFILE:
if (!-f 'Makefile.PL') {
unless (just_pm_to_blib($target, $ext_dir, $mname, $return_dir)) {
print "\nRunning Makefile.PL in $ext_dir\n" if $verbose;
my @args = ("-I$lib_dir", 'Makefile.PL');
- if ($is_VMS) {
+ if (IS_VMS) {
my $libd = VMS::Filespec::vmspath($lib_dir);
push @args, "INST_LIB=$libd", "INST_ARCHLIB=$libd";
} else {
'INSTALLMAN3DIR=none';
}
push @args, @$pass_through;
- _quote_args(\@args) if $is_VMS;
+ _quote_args(\@args) if IS_VMS;
print join(' ', $perl, @args), "\n" if $verbose;
my $code = do {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
# some of them rely on a $(PERL) for their own distclean targets.
# But this always used to be a problem with the old /bin/sh version of
# this.
- if ($is_Unix) {
+ if (IS_UNIX) {
foreach my $clean_target ('realclean', 'veryclean') {
fallback_cleanup($return_dir, $clean_target, <<"EOS");
cd $ext_dir
print "Warning: No Makefile!\n";
}
- if ($is_VMS) {
+ if (IS_VMS) {
_quote_args($pass_through);
@$pass_through = (
"/DESCRIPTION=$makefile",
);
}
- if (!$target or $target !~ /clean$/) {
- # Give makefile an opportunity to rewrite itself.
- # reassure users that life goes on...
- my @args = ('config', @$pass_through);
- system(@make, @args) and print "@make @args failed, continuing anyway...\n";
- }
my @targ = ($target, @$pass_through);
print "Making $target in $ext_dir\n@make @targ\n" if $verbose;
local $ENV{PERL_INSTALL_QUIET} = 1;
my $code = system(@make, @targ);
+ if($code >> 8 != 0){ # probably cleaned itself, try again once more time
+ $code = system(@make, @targ);
+ }
die "Unsuccessful make($ext_dir): code=$code" if $code != 0;
chdir $return_dir || die "Cannot cd to $return_dir: $!";
my ($last) = $mname =~ /([^:]+)$/;
my ($first) = $mname =~ /^([^:]+)/;
- my $pm_to_blib = $is_VMS ? 'pm_to_blib.ts' : 'pm_to_blib';
+ my $pm_to_blib = IS_VMS ? 'pm_to_blib.ts' : 'pm_to_blib';
foreach my $leaf (<*>) {
if (-d $leaf) {
$leaf =~ s/\.DIR\z//i
- if $is_VMS;
+ if IS_VMS;
next if $leaf =~ /\A(?:\.|\.\.|t|demo)\z/;
if ($leaf eq 'lib') {
++$has_lib;
return $leaf
unless -f _;
$leaf =~ s/\.\z//
- if $is_VMS;
+ if IS_VMS;
# Makefile.PL is "safe" to ignore because we will only be called for
# directories that hold a Makefile.PL if they are in the exception list.
next
print $fh "$0 has handled pm_to_blib directly\n";
close $fh
or die "Can't close '$pm_to_blib': $!";
- if ($is_Unix) {
+ if (IS_UNIX) {
# Fake the fallback cleanup
my $fallback
= join '', map {s!^\.\./\.\./!!; "rm -f $_\n"} sort values %pm;
Perl_debstackptrs
Perl_pad_sv
Perl_pad_setsv
+ Perl_set_padlist
Perl_hv_assert
PL_watchaddr
PL_watchok
Perl_my_cxt_index
);
}
+if ($define{'NO_MATHOMS'}) {
+ ++$skip{$_} foreach qw(
+ ASCII_TO_NEED
+ NATIVE_TO_NEED
+ Perl_custom_op_desc
+ Perl_custom_op_name
+ Perl_do_aexec
+ Perl_do_binmode
+ Perl_do_open
+ Perl_do_open9
+ Perl_fprintf_nocontext
+ Perl_gv_AVadd
+ Perl_gv_HVadd
+ Perl_gv_IOadd
+ Perl_gv_SVadd
+ Perl_gv_efullname
+ Perl_gv_efullname3
+ Perl_gv_fetchmethod
+ Perl_gv_fullname
+ Perl_gv_fullname3
+ Perl_hv_delete
+ Perl_hv_delete_ent
+ Perl_hv_exists
+ Perl_hv_exists_ent
+ Perl_hv_fetch
+ Perl_hv_fetch_ent
+ Perl_hv_iternext
+ Perl_hv_magic
+ Perl_hv_store
+ Perl_hv_store_ent
+ Perl_hv_store_flags
+ Perl_init_i18nl14n
+ Perl_isALNUM_lazy
+ Perl_isIDFIRST_lazy
+ Perl_is_uni_alnum
+ Perl_is_uni_alnum_lc
+ Perl_is_uni_alnumc
+ Perl_is_uni_alnumc_lc
+ Perl_is_uni_alpha
+ Perl_is_uni_alpha_lc
+ Perl_is_uni_ascii
+ Perl_is_uni_ascii_lc
+ Perl_is_uni_blank
+ Perl_is_uni_blank_lc
+ Perl_is_uni_cntrl
+ Perl_is_uni_cntrl_lc
+ Perl_is_uni_digit
+ Perl_is_uni_digit_lc
+ Perl_is_uni_graph
+ Perl_is_uni_graph_lc
+ Perl_is_uni_idfirst
+ Perl_is_uni_idfirst_lc
+ Perl_is_uni_lower
+ Perl_is_uni_lower_lc
+ Perl_is_uni_print
+ Perl_is_uni_print_lc
+ Perl_is_uni_punct
+ Perl_is_uni_punct_lc
+ Perl_is_uni_space
+ Perl_is_uni_space_lc
+ Perl_is_uni_upper
+ Perl_is_uni_upper_lc
+ Perl_is_uni_xdigit
+ Perl_is_uni_xdigit_lc
+ Perl_is_utf8_alnum
+ Perl_is_utf8_alnumc
+ Perl_is_utf8_alpha
+ Perl_is_utf8_ascii
+ Perl_is_utf8_blank
+ Perl_is_utf8_char
+ Perl_is_utf8_cntrl
+ Perl_is_utf8_digit
+ Perl_is_utf8_graph
+ Perl_is_utf8_idcont
+ Perl_is_utf8_idfirst
+ Perl_is_utf8_lower
+ Perl_is_utf8_mark
+ Perl_is_utf8_perl_space
+ Perl_is_utf8_perl_word
+ Perl_is_utf8_posix_digit
+ Perl_is_utf8_print
+ Perl_is_utf8_punct
+ Perl_is_utf8_space
+ Perl_is_utf8_string_loc
+ Perl_is_utf8_upper
+ Perl_is_utf8_xdigit
+ Perl_is_utf8_xidcont
+ Perl_is_utf8_xidfirst
+ Perl_my_lstat
+ Perl_my_stat
+ Perl_newAV
+ Perl_newHV
+ Perl_newIO
+ Perl_newSUB
+ Perl_pack_cat
+ Perl_printf_nocontext
+ Perl_ref
+ Perl_save_freeop
+ Perl_save_freepv
+ Perl_save_freesv
+ Perl_save_iv
+ Perl_save_list
+ Perl_save_long
+ Perl_save_mortalizesv
+ Perl_save_nogv
+ Perl_save_op
+ Perl_save_re_context
+ Perl_sv_2iv
+ Perl_sv_2pv
+ Perl_sv_2pv_nolen
+ Perl_sv_2pvbyte_nolen
+ Perl_sv_2pvutf8_nolen
+ Perl_sv_2uv
+ Perl_sv_catpvn
+ Perl_sv_catpvn_mg
+ Perl_sv_catsv
+ Perl_sv_catsv_mg
+ Perl_sv_force_normal
+ Perl_sv_insert
+ Perl_sv_iv
+ Perl_sv_mortalcopy
+ Perl_sv_nolocking
+ Perl_sv_nounlocking
+ Perl_sv_nv
+ Perl_sv_pv
+ Perl_sv_pvbyte
+ Perl_sv_pvbyten
+ Perl_sv_pvn
+ Perl_sv_pvn_force
+ Perl_sv_pvn_nomg
+ Perl_sv_pvutf8
+ Perl_sv_pvutf8n
+ Perl_sv_setsv
+ Perl_sv_taint
+ Perl_sv_unref
+ Perl_sv_usepvn
+ Perl_sv_usepvn_mg
+ Perl_sv_utf8_upgrade
+ Perl_sv_uv
+ Perl_to_uni_lower_lc
+ Perl_to_uni_title_lc
+ Perl_to_uni_upper_lc
+ Perl_to_utf8_fold
+ Perl_to_utf8_lower
+ Perl_to_utf8_title
+ Perl_to_utf8_upper
+ Perl_unpack_str
+ Perl_utf8_to_uvchr
+ Perl_utf8_to_uvuni
+ Perl_valid_utf8_to_uvuni
+ );
+}
unless ($define{'PERL_NEED_APPCTX'}) {
++$skip{PL_appctx};
Perl_PerlIO_get_cnt
Perl_PerlIO_get_ptr
Perl_PerlIO_read
+ Perl_PerlIO_restore_errno
+ Perl_PerlIO_save_errno
Perl_PerlIO_seek
Perl_PerlIO_set_cnt
Perl_PerlIO_set_ptrcnt
# && defined(BAR) /* comment */ \
# && defined(BAZ) /* comment */ \
# etc.
- # This code processes these latter situations first; it assumes there is
- # at most one straightforward comment per continued preprocessor line. (It
- # would be easier to handle more general cases if sed had a non-greedy '*'
- # quantifier; but typically preprocessor directive lines are rather
- # simple.) The continuation line is joined, and the process repeated on
- # the enlarged line as long as there are continuations. At the end, if
- # there are any comments remaining, they should be like the first situation,
- # and can just be deleted. (Subsequent lines of the comment are irrelevant
- # and get dropped.)
- ( $echo "#line 2 \"$file\""; \
- $sed -n <$file \
- -e "/^${filebase}_init(/q" \
- -e ': testcont' \
- -e '/^[ ]*#/s|/\*.*\*/||' \
- -e '/\\$/{' \
- -e 'N' \
- -e 'b testcont' \
- -e '}' \
- -e 's/\\\n/ /g' \
- -e '/^#line/d' \
- -e '/^[ ]*#/{' \
- -e 's|/\*.*$||' \
- -e p \
+ # Also, in lines like
+ # #defined FOO(a,b) a/**/b
+ # the comment may be important and so needs to be retained.
+ # This code processes the single-line comments first; it assumes there is
+ # at most one straightforward comment per continued preprocessor line,
+ # replacing each non-empty comment (and its surrounding white space) by a
+ # single space. (sed only has a greedy '*' quantifier, so this doesn't
+ # work right if there are multiple comments per line, and strings can look
+ # like comments to it; both are unlikely in a preprocessor statement.) Any
+ # continuation line is joined, and the process repeated on the enlarged
+ # line as long as there are continuations. At the end, if there are any
+ # comments remaining, they are either completely empty or are like the
+ # first situation. The latter are just deleted by first deleting to the
+ # end of line (including preceding white space) things that start with '/*'
+ # and the next char isn't a '*'; then things that start with '/**', but the
+ # next char isn't a '/'. (Subsequent lines of the comment are irrelevant
+ # and get dropped.) At the end, we unjoin very long lines to avoid
+ # preprocessor limitations
+ ( $echo "#line 2 \"$file\""; \
+ $sed -n <$file \
+ -e "/^${filebase}_init(/q" \
+ -e ': testcont' \
+ -e '/^[ ]*#/s|[ ]*/\*..*\*/[ ]*| |' \
+ -e '/\\$/{' \
+ -e 'N' \
+ -e 'b testcont' \
+ -e '}' \
+ -e 's/\\\n//g' \
+ -e '/^#line/d' \
+ -e '/^[ ]*#/{' \
+ -e 's|[ ]*/\*[^*].*$||' \
+ -e 's|[ ]*/\*\*[^/].*$||' \
+ -e 's/.\{255\}/&\\\n/g' \
+ -e p \
-e '}' ) >UU/$file.c
- if [ "$osname" = os390 -a "$file" = perly.c ]; then
- $echo '#endif' >>UU/$file.c
- fi
+ # We're not sure why this was there; the #endif is extraneous on modern z/OS
+ #if [ "$osname" = os390 -a "$file" = perly.c ]; then
+ # $echo '#endif' >>UU/$file.c
+ #fi
if [ "$osname" = os390 ]; then
$cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
* in Configure, this is the way to force them into availability.
*
* BOOTSTRAP_CHARSET
+ * DOUBLEKIND
* HAS_ACOSH
* HAS_ASCTIME64
* HAS_CTIME64
* I64SIZE
* I8SIZE
* LOCALTIME_R_NEEDS_TZSET
+ * LONG_DOUBLEKIND
* U8SIZE
* USE_CBACKTRACE
*/
IV val= SvIV(referent);
if (val <= 0) {
tmpsv= &PL_sv_undef;
- Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
"Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef",
SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
);
"/* lvref '\\' Lvalue reference constructor */" },
{ ']', "want_vtbl_checkcall | PERL_MAGIC_VALUE_MAGIC",
"/* checkcall ']' Inlining/mutation of call to this CV */" },
- { '~', "magic_vtable_max",
+ { '~', "magic_vtable_max | PERL_MAGIC_READONLY_ACCEPTABLE",
"/* ext '~' Available for use by extensions */" },
/* ex: set ro: */
optimize='$optimize',
cppflags='$cppflags'
ccversion='$ccversion', gccversion='$gccversion', gccosandvers='$gccosandvers'
- intsize=$intsize, longsize=$longsize, ptrsize=$ptrsize, doublesize=$doublesize, byteorder=$byteorder
+ intsize=$intsize, longsize=$longsize, ptrsize=$ptrsize, doublesize=$doublesize, byteorder=$byteorder, doublekind=$doublekind
d_longlong=$d_longlong, longlongsize=$longlongsize, d_longdbl=$d_longdbl, longdblsize=$longdblsize, longdblkind=$longdblkind
ivtype='$ivtype', ivsize=$ivsize, nvtype='$nvtype', nvsize=$nvsize, Off_t='$lseektype', lseeksize=$lseeksize
alignbytes=$alignbytes, prototype=$prototype
#define FILE struct _FILE
#endif
+#ifndef EBCDIC
+
#define _CANNOT "CANNOT"
#undef clearerr
#define pclose(f) _CANNOT _pclose_
#endif
+#endif /*not define EBCDIC */
+
/*
* Local variables:
* c-indentation-style: bsd
{
const char* s = *sp;
int flags = 0;
+ bool odh = FALSE; /* one dot hash: 1.#INF */
PERL_ARGS_ASSERT_GROK_INFNAN;
s++; if (s == send) return 0;
} else
return 0;
+ odh = TRUE;
}
if (isALPHA_FOLD_EQ(*s, 'I')) {
return 0;
flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
}
- else if (isALPHA_FOLD_EQ(*s, 'D')) {
+ else if (isALPHA_FOLD_EQ(*s, 'D') && odh) { /* 1.#IND */
s++;
flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
} else
#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
+/* Used to avoid recursion through the op tree in scalarvoid() and
+ op_free()
+*/
+
+#define DEFERRED_OP_STEP 100
+#define DEFER_OP(o) \
+ STMT_START { \
+ if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
+ defer_stack_alloc += DEFERRED_OP_STEP; \
+ assert(defer_stack_alloc > 0); \
+ Renew(defer_stack, defer_stack_alloc, OP *); \
+ } \
+ defer_stack[++defer_ix] = o; \
+ } STMT_END
+
+#define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
+
/* remove any leading "empty" ops from the op_next chain whose first
* node's address is stored in op_p. Store the updated address of the
* first node in op_p.
{
dVAR;
OPCODE type;
+ SSize_t defer_ix = -1;
+ SSize_t defer_stack_alloc = 0;
+ OP **defer_stack = NULL;
- /* Though ops may be freed twice, freeing the op after its slab is a
- big no-no. */
- assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
- /* During the forced freeing of ops after compilation failure, kidops
- may be freed before their parents. */
- if (!o || o->op_type == OP_FREED)
- return;
+ do {
- type = o->op_type;
+ /* Though ops may be freed twice, freeing the op after its slab is a
+ big no-no. */
+ assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
+ /* During the forced freeing of ops after compilation failure, kidops
+ may be freed before their parents. */
+ if (!o || o->op_type == OP_FREED)
+ continue;
- /* 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 */
- if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
- assert(!(o->op_private & ~PL_op_private_valid[type]));
- }
+ type = o->op_type;
- if (o->op_private & OPpREFCOUNTED) {
- switch (type) {
- case OP_LEAVESUB:
- case OP_LEAVESUBLV:
- case OP_LEAVEEVAL:
- case OP_LEAVE:
- case OP_SCOPE:
- case OP_LEAVEWRITE:
- {
- PADOFFSET refcnt;
- OP_REFCNT_LOCK;
- refcnt = OpREFCNT_dec(o);
- OP_REFCNT_UNLOCK;
- if (refcnt) {
- /* Need to find and remove any pattern match ops from the list
- we maintain for reset(). */
- find_and_forget_pmops(o);
- return;
- }
- }
- break;
- default:
- break;
- }
- }
+ /* 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 */
+ if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
+ assert(!(o->op_private & ~PL_op_private_valid[type]));
+ }
- /* Call the op_free hook if it has been set. Do it now so that it's called
- * at the right time for refcounted ops, but still before all of the kids
- * are freed. */
- CALL_OPFREEHOOK(o);
+ if (o->op_private & OPpREFCOUNTED) {
+ switch (type) {
+ case OP_LEAVESUB:
+ case OP_LEAVESUBLV:
+ case OP_LEAVEEVAL:
+ case OP_LEAVE:
+ case OP_SCOPE:
+ case OP_LEAVEWRITE:
+ {
+ PADOFFSET refcnt;
+ OP_REFCNT_LOCK;
+ refcnt = OpREFCNT_dec(o);
+ OP_REFCNT_UNLOCK;
+ if (refcnt) {
+ /* Need to find and remove any pattern match ops from the list
+ we maintain for reset(). */
+ find_and_forget_pmops(o);
+ continue;
+ }
+ }
+ break;
+ default:
+ break;
+ }
+ }
- if (o->op_flags & OPf_KIDS) {
- OP *kid, *nextkid;
- for (kid = cUNOPo->op_first; kid; kid = nextkid) {
- nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
- op_free(kid);
- }
- }
- if (type == OP_NULL)
- type = (OPCODE)o->op_targ;
+ /* Call the op_free hook if it has been set. Do it now so that it's called
+ * at the right time for refcounted ops, but still before all of the kids
+ * are freed. */
+ CALL_OPFREEHOOK(o);
+
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid, *nextkid;
+ for (kid = cUNOPo->op_first; kid; kid = nextkid) {
+ nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
+ if (!kid || kid->op_type == OP_FREED)
+ /* During the forced freeing of ops after
+ compilation failure, kidops may be freed before
+ their parents. */
+ continue;
+ if (!(kid->op_flags & OPf_KIDS))
+ /* If it has no kids, just free it now */
+ op_free(kid);
+ else
+ DEFER_OP(kid);
+ }
+ }
+ if (type == OP_NULL)
+ type = (OPCODE)o->op_targ;
- if (o->op_slabbed)
- Slab_to_rw(OpSLAB(o));
+ if (o->op_slabbed)
+ Slab_to_rw(OpSLAB(o));
- /* COP* is not cleared by op_clear() so that we may track line
- * numbers etc even after null() */
- if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
- cop_free((COP*)o);
- }
+ /* COP* is not cleared by op_clear() so that we may track line
+ * numbers etc even after null() */
+ if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
+ cop_free((COP*)o);
+ }
- op_clear(o);
- FreeOp(o);
+ op_clear(o);
+ FreeOp(o);
#ifdef DEBUG_LEAKING_SCALARS
- if (PL_op == o)
- PL_op = NULL;
+ if (PL_op == o)
+ PL_op = NULL;
#endif
+ } while ( (o = POP_DEFERRED_OP()) );
+
+ Safefree(defer_stack);
}
void
return;
op_clear(o);
o->op_targ = o->op_type;
- o->op_type = OP_NULL;
- o->op_ppaddr = PL_ppaddr[OP_NULL];
+ CHANGE_TYPE(o, OP_NULL);
}
void
LOGOP *
S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
{
+ dVAR;
LOGOP *logop;
OP *kid = first;
NewOp(1101, logop, 1, LOGOP);
- logop->op_type = (OPCODE)type;
+ CHANGE_TYPE(logop, type);
logop->op_first = first;
logop->op_other = other;
logop->op_flags = OPf_KIDS;
switch (o->op_type) {
case OP_REPEAT:
scalar(cBINOPo->op_first);
+ if (o->op_private & OPpREPEAT_DOLIST) {
+ kid = cLISTOPx(cUNOPo->op_first)->op_first;
+ assert(kid->op_type == OP_PUSHMARK);
+ if (OP_HAS_SIBLING(kid) && !OP_HAS_SIBLING(OP_SIBLING(kid))) {
+ op_null(cLISTOPx(cUNOPo->op_first)->op_first);
+ o->op_private &=~ OPpREPEAT_DOLIST;
+ }
+ }
break;
case OP_OR:
case OP_AND:
}
OP *
-Perl_scalarvoid(pTHX_ OP *o)
+Perl_scalarvoid(pTHX_ OP *arg)
{
dVAR;
OP *kid;
- SV *useless_sv = NULL;
- const char* useless = NULL;
SV* sv;
U8 want;
+ SSize_t defer_stack_alloc = 0;
+ SSize_t defer_ix = -1;
+ OP **defer_stack = NULL;
+ OP *o = arg;
PERL_ARGS_ASSERT_SCALARVOID;
- if (o->op_type == OP_NEXTSTATE
- || o->op_type == OP_DBSTATE
- || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
- || o->op_targ == OP_DBSTATE)))
- PL_curcop = (COP*)o; /* for warning below */
+ do {
+ SV *useless_sv = NULL;
+ const char* useless = NULL;
+
+ if (o->op_type == OP_NEXTSTATE
+ || o->op_type == OP_DBSTATE
+ || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
+ || o->op_targ == OP_DBSTATE)))
+ PL_curcop = (COP*)o; /* for warning below */
+
+ /* assumes no premature commitment */
+ want = o->op_flags & OPf_WANT;
+ if ((want && want != OPf_WANT_SCALAR)
+ || (PL_parser && PL_parser->error_count)
+ || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
+ {
+ continue;
+ }
- /* assumes no premature commitment */
- want = o->op_flags & OPf_WANT;
- if ((want && want != OPf_WANT_SCALAR)
- || (PL_parser && PL_parser->error_count)
- || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
- {
- return o;
- }
+ if ((o->op_private & OPpTARGET_MY)
+ && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
+ {
+ /* newASSIGNOP has already applied scalar context, which we
+ leave, as if this op is inside SASSIGN. */
+ continue;
+ }
- if ((o->op_private & OPpTARGET_MY)
- && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
- {
- return scalar(o); /* As if inside SASSIGN */
- }
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
- o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+ switch (o->op_type) {
+ default:
+ if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
+ break;
+ /* FALLTHROUGH */
+ case OP_REPEAT:
+ if (o->op_flags & OPf_STACKED)
+ break;
+ goto func_ops;
+ case OP_SUBSTR:
+ if (o->op_private == 4)
+ break;
+ /* FALLTHROUGH */
+ case OP_WANTARRAY:
+ case OP_GV:
+ case OP_SMARTMATCH:
+ case OP_AV2ARYLEN:
+ case OP_REF:
+ case OP_REFGEN:
+ case OP_SREFGEN:
+ case OP_DEFINED:
+ case OP_HEX:
+ case OP_OCT:
+ case OP_LENGTH:
+ case OP_VEC:
+ case OP_INDEX:
+ case OP_RINDEX:
+ case OP_SPRINTF:
+ case OP_KVASLICE:
+ case OP_KVHSLICE:
+ case OP_UNPACK:
+ case OP_PACK:
+ case OP_JOIN:
+ case OP_LSLICE:
+ case OP_ANONLIST:
+ case OP_ANONHASH:
+ case OP_SORT:
+ case OP_REVERSE:
+ case OP_RANGE:
+ case OP_FLIP:
+ case OP_FLOP:
+ case OP_CALLER:
+ case OP_FILENO:
+ case OP_EOF:
+ case OP_TELL:
+ case OP_GETSOCKNAME:
+ case OP_GETPEERNAME:
+ case OP_READLINK:
+ case OP_TELLDIR:
+ case OP_GETPPID:
+ case OP_GETPGRP:
+ case OP_GETPRIORITY:
+ case OP_TIME:
+ case OP_TMS:
+ case OP_LOCALTIME:
+ case OP_GMTIME:
+ case OP_GHBYNAME:
+ case OP_GHBYADDR:
+ case OP_GHOSTENT:
+ case OP_GNBYNAME:
+ case OP_GNBYADDR:
+ case OP_GNETENT:
+ case OP_GPBYNAME:
+ case OP_GPBYNUMBER:
+ case OP_GPROTOENT:
+ case OP_GSBYNAME:
+ case OP_GSBYPORT:
+ case OP_GSERVENT:
+ case OP_GPWNAM:
+ case OP_GPWUID:
+ case OP_GGRNAM:
+ case OP_GGRGID:
+ case OP_GETLOGIN:
+ case OP_PROTOTYPE:
+ case OP_RUNCV:
+ func_ops:
+ useless = OP_DESC(o);
+ break;
- switch (o->op_type) {
- default:
- if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
- break;
- /* FALLTHROUGH */
- case OP_REPEAT:
- if (o->op_flags & OPf_STACKED)
- break;
- goto func_ops;
- case OP_SUBSTR:
- if (o->op_private == 4)
- break;
- /* FALLTHROUGH */
- case OP_GVSV:
- case OP_WANTARRAY:
- case OP_GV:
- case OP_SMARTMATCH:
- case OP_PADSV:
- case OP_PADAV:
- case OP_PADHV:
- case OP_PADANY:
- case OP_AV2ARYLEN:
- case OP_REF:
- case OP_REFGEN:
- case OP_SREFGEN:
- case OP_DEFINED:
- case OP_HEX:
- case OP_OCT:
- case OP_LENGTH:
- case OP_VEC:
- case OP_INDEX:
- case OP_RINDEX:
- case OP_SPRINTF:
- case OP_AELEM:
- case OP_AELEMFAST:
- case OP_AELEMFAST_LEX:
- case OP_ASLICE:
- case OP_KVASLICE:
- case OP_HELEM:
- case OP_HSLICE:
- case OP_KVHSLICE:
- case OP_UNPACK:
- case OP_PACK:
- case OP_JOIN:
- case OP_LSLICE:
- case OP_ANONLIST:
- case OP_ANONHASH:
- case OP_SORT:
- case OP_REVERSE:
- case OP_RANGE:
- case OP_FLIP:
- case OP_FLOP:
- case OP_CALLER:
- case OP_FILENO:
- case OP_EOF:
- case OP_TELL:
- case OP_GETSOCKNAME:
- case OP_GETPEERNAME:
- case OP_READLINK:
- case OP_TELLDIR:
- case OP_GETPPID:
- case OP_GETPGRP:
- case OP_GETPRIORITY:
- case OP_TIME:
- case OP_TMS:
- case OP_LOCALTIME:
- case OP_GMTIME:
- case OP_GHBYNAME:
- case OP_GHBYADDR:
- case OP_GHOSTENT:
- case OP_GNBYNAME:
- case OP_GNBYADDR:
- case OP_GNETENT:
- case OP_GPBYNAME:
- case OP_GPBYNUMBER:
- case OP_GPROTOENT:
- case OP_GSBYNAME:
- case OP_GSBYPORT:
- case OP_GSERVENT:
- case OP_GPWNAM:
- case OP_GPWUID:
- case OP_GGRNAM:
- case OP_GGRGID:
- case OP_GETLOGIN:
- case OP_PROTOTYPE:
- case OP_RUNCV:
- func_ops:
- if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
- /* Otherwise it's "Useless use of grep iterator" */
- useless = OP_DESC(o);
- break;
+ case OP_GVSV:
+ case OP_PADSV:
+ case OP_PADAV:
+ case OP_PADHV:
+ case OP_PADANY:
+ case OP_AELEM:
+ case OP_AELEMFAST:
+ case OP_AELEMFAST_LEX:
+ case OP_ASLICE:
+ case OP_HELEM:
+ case OP_HSLICE:
+ if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
+ /* Otherwise it's "Useless use of grep iterator" */
+ useless = OP_DESC(o);
+ break;
- case OP_SPLIT:
- kid = cLISTOPo->op_first;
- if (kid && kid->op_type == OP_PUSHRE
- && !kid->op_targ
- && !(o->op_flags & OPf_STACKED)
+ case OP_SPLIT:
+ kid = cLISTOPo->op_first;
+ if (kid && kid->op_type == OP_PUSHRE
+ && !kid->op_targ
+ && !(o->op_flags & OPf_STACKED)
#ifdef USE_ITHREADS
- && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
+ && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
#else
- && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
+ && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
#endif
- useless = OP_DESC(o);
- break;
+ )
+ useless = OP_DESC(o);
+ break;
- case OP_NOT:
- kid = cUNOPo->op_first;
- if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
- kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
- goto func_ops;
- }
- useless = "negative pattern binding (!~)";
- break;
+ case OP_NOT:
+ kid = cUNOPo->op_first;
+ if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
+ kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
+ goto func_ops;
+ }
+ useless = "negative pattern binding (!~)";
+ break;
- case OP_SUBST:
- if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
- useless = "non-destructive substitution (s///r)";
- break;
+ case OP_SUBST:
+ if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
+ useless = "non-destructive substitution (s///r)";
+ break;
- case OP_TRANSR:
- useless = "non-destructive transliteration (tr///r)";
- break;
+ case OP_TRANSR:
+ useless = "non-destructive transliteration (tr///r)";
+ break;
- case OP_RV2GV:
- case OP_RV2SV:
- case OP_RV2AV:
- case OP_RV2HV:
- if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
- (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
- useless = "a variable";
- break;
+ case OP_RV2GV:
+ case OP_RV2SV:
+ case OP_RV2AV:
+ case OP_RV2HV:
+ if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
+ (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
+ useless = "a variable";
+ break;
- case OP_CONST:
- sv = cSVOPo_sv;
- if (cSVOPo->op_private & OPpCONST_STRICT)
- no_bareword_allowed(o);
- else {
- if (ckWARN(WARN_VOID)) {
- NV nv;
- /* don't warn on optimised away booleans, eg
- * use constant Foo, 5; Foo || print; */
- if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
- useless = NULL;
- /* the constants 0 and 1 are permitted as they are
- conventionally used as dummies in constructs like
- 1 while some_condition_with_side_effects; */
- else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
- useless = NULL;
- else if (SvPOK(sv)) {
- SV * const dsv = newSVpvs("");
- useless_sv
- = Perl_newSVpvf(aTHX_
- "a constant (%s)",
- pv_pretty(dsv, SvPVX_const(sv),
- SvCUR(sv), 32, NULL, NULL,
- PERL_PV_PRETTY_DUMP
- | PERL_PV_ESCAPE_NOCLEAR
- | PERL_PV_ESCAPE_UNI_DETECT));
- SvREFCNT_dec_NN(dsv);
- }
- else if (SvOK(sv)) {
- useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
- }
- else
- useless = "a constant (undef)";
- }
- }
- op_null(o); /* don't execute or even remember it */
- break;
+ case OP_CONST:
+ sv = cSVOPo_sv;
+ if (cSVOPo->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(o);
+ else {
+ if (ckWARN(WARN_VOID)) {
+ NV nv;
+ /* don't warn on optimised away booleans, eg
+ * use constant Foo, 5; Foo || print; */
+ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
+ useless = NULL;
+ /* the constants 0 and 1 are permitted as they are
+ conventionally used as dummies in constructs like
+ 1 while some_condition_with_side_effects; */
+ else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
+ useless = NULL;
+ else if (SvPOK(sv)) {
+ SV * const dsv = newSVpvs("");
+ useless_sv
+ = Perl_newSVpvf(aTHX_
+ "a constant (%s)",
+ pv_pretty(dsv, SvPVX_const(sv),
+ SvCUR(sv), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP
+ | PERL_PV_ESCAPE_NOCLEAR
+ | PERL_PV_ESCAPE_UNI_DETECT));
+ SvREFCNT_dec_NN(dsv);
+ }
+ else if (SvOK(sv)) {
+ useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
+ }
+ else
+ useless = "a constant (undef)";
+ }
+ }
+ op_null(o); /* don't execute or even remember it */
+ break;
- case OP_POSTINC:
- o->op_type = OP_PREINC; /* pre-increment is faster */
- o->op_ppaddr = PL_ppaddr[OP_PREINC];
- break;
+ case OP_POSTINC:
+ CHANGE_TYPE(o, OP_PREINC); /* pre-increment is faster */
+ break;
- case OP_POSTDEC:
- o->op_type = OP_PREDEC; /* pre-decrement is faster */
- o->op_ppaddr = PL_ppaddr[OP_PREDEC];
- break;
+ case OP_POSTDEC:
+ CHANGE_TYPE(o, OP_PREDEC); /* pre-decrement is faster */
+ break;
- case OP_I_POSTINC:
- o->op_type = OP_I_PREINC; /* pre-increment is faster */
- o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
- break;
+ case OP_I_POSTINC:
+ CHANGE_TYPE(o, OP_I_PREINC); /* pre-increment is faster */
+ break;
- case OP_I_POSTDEC:
- o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
- o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
- break;
+ case OP_I_POSTDEC:
+ CHANGE_TYPE(o, OP_I_PREDEC); /* pre-decrement is faster */
+ break;
- case OP_SASSIGN: {
- OP *rv2gv;
- UNOP *refgen, *rv2cv;
- LISTOP *exlist;
+ case OP_SASSIGN: {
+ OP *rv2gv;
+ UNOP *refgen, *rv2cv;
+ LISTOP *exlist;
- if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
- break;
+ if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
+ break;
- rv2gv = ((BINOP *)o)->op_last;
- if (!rv2gv || rv2gv->op_type != OP_RV2GV)
- break;
+ rv2gv = ((BINOP *)o)->op_last;
+ if (!rv2gv || rv2gv->op_type != OP_RV2GV)
+ break;
- refgen = (UNOP *)((BINOP *)o)->op_first;
+ refgen = (UNOP *)((BINOP *)o)->op_first;
- if (!refgen || (refgen->op_type != OP_REFGEN
- && refgen->op_type != OP_SREFGEN))
- break;
+ if (!refgen || (refgen->op_type != OP_REFGEN
+ && refgen->op_type != OP_SREFGEN))
+ break;
- exlist = (LISTOP *)refgen->op_first;
- if (!exlist || exlist->op_type != OP_NULL
- || exlist->op_targ != OP_LIST)
- break;
+ exlist = (LISTOP *)refgen->op_first;
+ if (!exlist || exlist->op_type != OP_NULL
+ || exlist->op_targ != OP_LIST)
+ break;
- if (exlist->op_first->op_type != OP_PUSHMARK
- && exlist->op_first != exlist->op_last)
- break;
+ if (exlist->op_first->op_type != OP_PUSHMARK
+ && exlist->op_first != exlist->op_last)
+ break;
- rv2cv = (UNOP*)exlist->op_last;
+ rv2cv = (UNOP*)exlist->op_last;
- if (rv2cv->op_type != OP_RV2CV)
- break;
+ if (rv2cv->op_type != OP_RV2CV)
+ break;
- assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
- assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
- assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
+ assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
+ assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
+ assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
- o->op_private |= OPpASSIGN_CV_TO_GV;
- rv2gv->op_private |= OPpDONT_INIT_GV;
- rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
+ o->op_private |= OPpASSIGN_CV_TO_GV;
+ rv2gv->op_private |= OPpDONT_INIT_GV;
+ rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
- break;
- }
+ break;
+ }
- case OP_AASSIGN: {
- inplace_aassign(o);
- break;
- }
+ case OP_AASSIGN: {
+ inplace_aassign(o);
+ break;
+ }
- case OP_OR:
- case OP_AND:
- kid = cLOGOPo->op_first;
- if (kid->op_type == OP_NOT
- && (kid->op_flags & OPf_KIDS)) {
- if (o->op_type == OP_AND) {
- o->op_type = OP_OR;
- o->op_ppaddr = PL_ppaddr[OP_OR];
- } else {
- o->op_type = OP_AND;
- o->op_ppaddr = PL_ppaddr[OP_AND];
- }
- op_null(kid);
- }
- /* FALLTHROUGH */
+ case OP_OR:
+ case OP_AND:
+ kid = cLOGOPo->op_first;
+ if (kid->op_type == OP_NOT
+ && (kid->op_flags & OPf_KIDS)) {
+ if (o->op_type == OP_AND) {
+ CHANGE_TYPE(o, OP_OR);
+ } else {
+ CHANGE_TYPE(o, OP_AND);
+ }
+ op_null(kid);
+ }
+ /* FALLTHROUGH */
+
+ case OP_DOR:
+ case OP_COND_EXPR:
+ case OP_ENTERGIVEN:
+ case OP_ENTERWHEN:
+ for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
+ if (!(kid->op_flags & OPf_KIDS))
+ scalarvoid(kid);
+ else
+ DEFER_OP(kid);
+ break;
- case OP_DOR:
- case OP_COND_EXPR:
- case OP_ENTERGIVEN:
- case OP_ENTERWHEN:
- for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
- scalarvoid(kid);
- break;
+ case OP_NULL:
+ if (o->op_flags & OPf_STACKED)
+ break;
+ /* FALLTHROUGH */
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ case OP_ENTERTRY:
+ case OP_ENTER:
+ if (!(o->op_flags & OPf_KIDS))
+ break;
+ /* FALLTHROUGH */
+ case OP_SCOPE:
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ case OP_LEAVELOOP:
+ case OP_LINESEQ:
+ case OP_LEAVEGIVEN:
+ case OP_LEAVEWHEN:
+ kids:
+ for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
+ if (!(kid->op_flags & OPf_KIDS))
+ scalarvoid(kid);
+ else
+ DEFER_OP(kid);
+ break;
+ case OP_LIST:
+ /* If the first kid after pushmark is something that the padrange
+ optimisation would reject, then null the list and the pushmark.
+ */
+ if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
+ && ( !(kid = OP_SIBLING(kid))
+ || ( kid->op_type != OP_PADSV
+ && kid->op_type != OP_PADAV
+ && kid->op_type != OP_PADHV)
+ || kid->op_private & ~OPpLVAL_INTRO
+ || !(kid = OP_SIBLING(kid))
+ || ( kid->op_type != OP_PADSV
+ && kid->op_type != OP_PADAV
+ && kid->op_type != OP_PADHV)
+ || kid->op_private & ~OPpLVAL_INTRO)
+ ) {
+ op_null(cUNOPo->op_first); /* NULL the pushmark */
+ op_null(o); /* NULL the list */
+ }
+ goto kids;
+ case OP_ENTEREVAL:
+ scalarkids(o);
+ break;
+ case OP_SCALAR:
+ scalar(o);
+ break;
+ }
- case OP_NULL:
- if (o->op_flags & OPf_STACKED)
- break;
- /* FALLTHROUGH */
- case OP_NEXTSTATE:
- case OP_DBSTATE:
- case OP_ENTERTRY:
- case OP_ENTER:
- if (!(o->op_flags & OPf_KIDS))
- break;
- /* FALLTHROUGH */
- case OP_SCOPE:
- case OP_LEAVE:
- case OP_LEAVETRY:
- case OP_LEAVELOOP:
- case OP_LINESEQ:
- case OP_LIST:
- case OP_LEAVEGIVEN:
- case OP_LEAVEWHEN:
- for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
- scalarvoid(kid);
- break;
- case OP_ENTEREVAL:
- scalarkids(o);
- break;
- case OP_SCALAR:
- return scalar(o);
- }
+ if (useless_sv) {
+ /* mortalise it, in case warnings are fatal. */
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %"SVf" in void context",
+ SVfARG(sv_2mortal(useless_sv)));
+ }
+ else if (useless) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %s in void context",
+ useless);
+ }
+ } while ( (o = POP_DEFERRED_OP()) );
- if (useless_sv) {
- /* mortalise it, in case warnings are fatal. */
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
- "Useless use of %"SVf" in void context",
- SVfARG(sv_2mortal(useless_sv)));
- }
- else if (useless) {
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
- "Useless use of %s in void context",
- useless);
- }
- return o;
+ Safefree(defer_stack);
+
+ return arg;
}
static OP *
switch (o->op_type) {
case OP_FLOP:
- case OP_REPEAT:
list(cBINOPo->op_first);
break;
+ case OP_REPEAT:
+ if (o->op_private & OPpREPEAT_DOLIST
+ && !(o->op_flags & OPf_STACKED))
+ {
+ list(cBINOPo->op_first);
+ kid = cBINOPo->op_last;
+ if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
+ && SvIVX(kSVOP_sv) == 1)
+ {
+ op_null(o); /* repeat */
+ op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
+ /* const (rhs): */
+ op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
+ }
+ }
+ break;
case OP_OR:
case OP_AND:
case OP_COND_EXPR:
list(cBINOPo->op_first);
return gen_constant_list(o);
}
+ listkids(o);
+ break;
case OP_LIST:
listkids(o);
+ if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
+ op_null(cUNOPo->op_first); /* NULL the pushmark */
+ op_null(o); /* NULL the list */
+ }
break;
case OP_LEAVE:
case OP_LEAVETRY:
=cut
*/
+static void
+S_mark_padname_lvalue(pTHX_ PADNAME *pn)
+{
+ CV *cv = PL_compcv;
+ PadnameLVALUE_on(pn);
+ while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
+ cv = CvOUTSIDE(cv);
+ assert(cv);
+ assert(CvPADLIST(cv));
+ pn =
+ PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
+ assert(PadnameLEN(pn));
+ PadnameLVALUE_on(pn);
+ }
+}
+
static bool
S_vivifies(const OPCODE type)
{
return;
}
slurpy:
- o->op_type = OP_LVAVREF;
- o->op_ppaddr = PL_ppaddr[OP_LVAVREF];
+ CHANGE_TYPE(o, OP_LVAVREF);
o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
o->op_flags |= OPf_MOD|OPf_REF;
return;
break;
case OP_ASLICE:
case OP_HSLICE:
- o->op_type = OP_LVREFSLICE;
- o->op_ppaddr = PL_ppaddr[OP_LVREFSLICE];
+ CHANGE_TYPE(o, OP_LVREFSLICE);
o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
return;
case OP_NULL:
PL_op_desc[type]));
return;
}
- o->op_type = OP_LVREF;
- o->op_ppaddr = PL_ppaddr[OP_LVREF];
+ CHANGE_TYPE(o, OP_LVREF);
o->op_private &=
OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
if (type == OP_ENTERLOOP)
case OP_ENTERSUB:
if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
- o->op_type = OP_RV2CV; /* entersub => rv2cv */
- o->op_ppaddr = PL_ppaddr[OP_RV2CV];
+ CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
case OP_MULTIPLY:
case OP_DIVIDE:
case OP_MODULO:
- case OP_REPEAT:
case OP_ADD:
case OP_SUBTRACT:
case OP_CONCAT:
PL_modcount++;
break;
+ case OP_REPEAT:
+ if (o->op_flags & OPf_STACKED) {
+ PL_modcount++;
+ break;
+ }
+ if (!(o->op_private & OPpREPEAT_DOLIST))
+ goto nomod;
+ else {
+ const I32 mods = PL_modcount;
+ modkids(cBINOPo->op_first, type);
+ if (type != OP_AASSIGN)
+ goto nomod;
+ kid = cBINOPo->op_last;
+ if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
+ const IV iv = SvIV(kSVOP_sv);
+ if (PL_modcount != RETURN_UNLIMITED_NUMBER)
+ PL_modcount =
+ mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
+ }
+ else
+ PL_modcount = RETURN_UNLIMITED_NUMBER;
+ }
+ break;
+
case OP_COND_EXPR:
localize = 1;
for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
if (!type) /* local() */
Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
PAD_COMPNAME_SV(o->op_targ));
+ if (!(o->op_private & OPpLVAL_INTRO)
+ || ( type != OP_SASSIGN && type != OP_AASSIGN
+ && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
+ S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
break;
case OP_PUSHMARK:
op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
op_null(o);
return o;
+
+ case OP_SPLIT:
+ kid = cLISTOPo->op_first;
+ if (kid && kid->op_type == OP_PUSHRE &&
+ ( kid->op_targ
+ || o->op_flags & OPf_STACKED
+#ifdef USE_ITHREADS
+ || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
+#else
+ || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
+#endif
+ )) {
+ /* This is actually @array = split. */
+ PL_modcount = RETURN_UNLIMITED_NUMBER;
+ break;
+ }
+ goto nomod;
}
/* [20011101.069] File test operators interpret OPf_REF to mean that
case OP_ENTERSUB:
if ((type == OP_EXISTS || type == OP_DEFINED) &&
!(o->op_flags & OPf_STACKED)) {
- o->op_type = OP_RV2CV; /* entersub => rv2cv */
- o->op_ppaddr = PL_ppaddr[OP_RV2CV];
+ CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
o->op_flags |= OPf_SPECIAL;
/* Fake up a method call to import */
meth = newSVpvs_share("import");
- imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
+ imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
op_append_elem(OP_LIST,
- op_prepend_elem(OP_LIST, pack, list(arg)),
+ op_prepend_elem(OP_LIST, pack, arg),
newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
/* Combine the ops. */
right->op_targ = 0;
right->op_private &= ~OPpTARGET_MY;
}
- if (!(right->op_flags & OPf_STACKED) && ismatchop) {
- OP *newleft;
-
- right->op_flags |= OPf_STACKED;
- if (rtype != OP_MATCH && rtype != OP_TRANSR &&
+ if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
+ if (left->op_type == OP_PADSV
+ && !(left->op_private & OPpLVAL_INTRO))
+ {
+ right->op_targ = left->op_targ;
+ op_free(left);
+ o = right;
+ }
+ else {
+ right->op_flags |= OPf_STACKED;
+ if (rtype != OP_MATCH && rtype != OP_TRANSR &&
! (rtype == OP_TRANS &&
right->op_private & OPpTRANS_IDENTICAL) &&
! (rtype == OP_SUBST &&
(cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
- newleft = op_lvalue(left, rtype);
- else
- newleft = left;
- if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
- o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
- else
- o = op_prepend_elem(rtype, scalar(newleft), right);
+ left = op_lvalue(left, rtype);
+ if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
+ o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
+ else
+ o = op_prepend_elem(rtype, scalar(left), right);
+ }
if (type == OP_NOT)
return newUNOP(OP_NOT, 0, scalar(o));
return o;
if (o) {
if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
- o->op_type = OP_LEAVE;
- o->op_ppaddr = PL_ppaddr[OP_LEAVE];
+ CHANGE_TYPE(o, OP_LEAVE);
}
else if (o->op_type == OP_LINESEQ) {
OP *kid;
- o->op_type = OP_SCOPE;
- o->op_ppaddr = PL_ppaddr[OP_SCOPE];
+ CHANGE_TYPE(o, OP_SCOPE);
kid = ((LISTOP*)o)->op_first;
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
op_null(kid);
return o;
}
+/*
+=for apidoc Am|int|block_start|int full
+
+Handles compile-time scope entry.
+Arranges for hints to be restored on block
+exit and also handles pad sequence numbers to make lexical variables scope
+right. Returns a savestack index for use with C<block_end>.
+
+=cut
+*/
+
int
Perl_block_start(pTHX_ int full)
{
const int retval = PL_savestack_ix;
+ PL_compiling.cop_seq = PL_cop_seqmax;
+ COP_SEQMAX_INC;
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
+ SAVEI32(PL_compiling.cop_seq);
+ PL_compiling.cop_seq = 0;
CALL_BLOCK_HOOKS(bhk_start, full);
return retval;
}
+/*
+=for apidoc Am|OP *|block_end|I32 floor|OP *seq
+
+Handles compile-time scope exit. I<floor>
+is the savestack index returned by
+C<block_start>, and I<seq> is the body of the block. Returns the block,
+possibly modified.
+
+=cut
+*/
+
OP*
Perl_block_end(pTHX_ I32 floor, OP *seq)
{
Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
}
-STATIC OP *
-S_newDEFSVOP(pTHX)
-{
- const PADOFFSET offset = pad_findmy_pvs("$_", 0);
- if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
- return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
- }
- else {
- OP * const o = newOP(OP_PADSV, 0);
- o->op_targ = offset;
- return o;
- }
-}
-
void
Perl_newPROG(pTHX_ OP *o)
{
if (o->op_type == OP_LIST) {
OP * const o2
= newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
- o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
+ o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
}
return o;
}
StructCopy(&PL_compiling, ¬_compiling, COP);
PL_curcop = ¬_compiling;
/* The above ensures that we run with all the correct hints of the
- currently compiling COP, but that IN_PERL_RUNTIME is not true. */
+ currently compiling COP, but that IN_PERL_RUNTIME is true. */
assert(IN_PERL_RUNTIME);
PL_warnhook = PERL_WARNHOOK_FATAL;
PL_diehook = NULL;
Perl_pp_anonlist(aTHX);
PL_tmps_floor = oldtmps_floor;
- o->op_type = OP_RV2AV;
- o->op_ppaddr = PL_ppaddr[OP_RV2AV];
+ CHANGE_TYPE(o, OP_RV2AV);
o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
o->op_opt = 0; /* needs to be revisited in rpeep() */
return list(o);
}
-/* convert o (and any siblings) into a list if not already, then
- * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it
- */
-
-OP *
-Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
-{
- dVAR;
- if (type < 0) type = -type, flags |= OPf_SPECIAL;
- if (!o || o->op_type != OP_LIST)
- o = force_list(o, 0);
- else
- o->op_flags &= ~OPf_WANT;
-
- if (!(PL_opargs[type] & OA_MARK))
- op_null(cLISTOPo->op_first);
- else {
- OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
- if (kid2 && kid2->op_type == OP_COREARGS) {
- op_null(cLISTOPo->op_first);
- kid2->op_private |= OPpCOREARGS_PUSHMARK;
- }
- }
-
- o->op_type = (OPCODE)type;
- o->op_ppaddr = PL_ppaddr[type];
- o->op_flags |= flags;
-
- o = CHECKOP(type, o);
- if (o->op_type != (unsigned)type)
- return o;
-
- return fold_constants(op_integerize(op_std_init(o)));
-}
-
/*
=head1 Optree Manipulation Functions
*/
if (!last)
return first;
- if (last->op_type == (unsigned)type) {
- if (type == OP_LIST) { /* already a PUSHMARK there */
- /* insert 'first' after pushmark */
- op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
- if (!(first->op_flags & OPf_PARENS))
- last->op_flags &= ~OPf_PARENS;
+ if (last->op_type == (unsigned)type) {
+ if (type == OP_LIST) { /* already a PUSHMARK there */
+ /* insert 'first' after pushmark */
+ op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
+ if (!(first->op_flags & OPf_PARENS))
+ last->op_flags &= ~OPf_PARENS;
+ }
+ else
+ op_sibling_splice(last, NULL, 0, first);
+ last->op_flags |= OPf_KIDS;
+ return last;
+ }
+
+ return newLISTOP(type, 0, first, last);
+}
+
+/*
+=for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
+
+Converts I<o> into a list op if it is not one already, and then converts it
+into the specified I<type>, calling its check function, allocating a target if
+it needs one, and folding constants.
+
+A list-type op is usually constructed one kid at a time via C<newLISTOP>,
+C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
+C<op_convert> to make it the right type.
+
+=cut
+*/
+
+OP *
+Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
+{
+ dVAR;
+ if (type < 0) type = -type, flags |= OPf_SPECIAL;
+ if (!o || o->op_type != OP_LIST)
+ o = force_list(o, 0);
+ else
+ o->op_flags &= ~OPf_WANT;
+
+ if (!(PL_opargs[type] & OA_MARK))
+ op_null(cLISTOPo->op_first);
+ else {
+ OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
+ if (kid2 && kid2->op_type == OP_COREARGS) {
+ op_null(cLISTOPo->op_first);
+ kid2->op_private |= OPpCOREARGS_PUSHMARK;
}
- else
- op_sibling_splice(last, NULL, 0, first);
- last->op_flags |= OPf_KIDS;
- return last;
}
- return newLISTOP(type, 0, first, last);
+ CHANGE_TYPE(o, type);
+ o->op_flags |= flags;
+
+ o = CHECKOP(type, o);
+ if (o->op_type != (unsigned)type)
+ return o;
+
+ return fold_constants(op_integerize(op_std_init(o)));
}
/* Constructors */
NewOp(1101, listop, 1, LISTOP);
- listop->op_type = (OPCODE)type;
- listop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(listop, type);
if (first || last)
flags |= OPf_KIDS;
listop->op_flags = (U8)flags;
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, o, 1, OP);
- o->op_type = (OPCODE)type;
- o->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(o, type);
o->op_flags = (U8)flags;
o->op_next = o;
first = force_list(first, 1);
NewOp(1101, unop, 1, UNOP);
- unop->op_type = (OPCODE)type;
- unop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(unop, type);
unop->op_first = first;
unop->op_flags = (U8)(flags | OPf_KIDS);
unop->op_private = (U8)(1 | (flags >> 8));
=for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
Constructs, checks, and returns an op of method type with a method name
-evaluated at runtime. I<type> is the opcode. I<flags> gives the eight
+evaluated at runtime. I<type> is the opcode. I<flags> gives the eight
bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
and, shifted up eight bits, the eight bits of C<op_private>, except that
-the bit with value 1 is automatically set. I<dynamic_meth> supplies an
+the bit with value 1 is automatically set. I<dynamic_meth> supplies an
op which evaluates method name; it is consumed by this function and
become part of the constructed op tree.
Supported optypes: OP_METHOD.
methop->op_flags = (U8)(flags | OPf_KIDS);
methop->op_u.op_first = dynamic_meth;
methop->op_private = (U8)(1 | (flags >> 8));
+
+#ifdef PERL_OP_PARENT
+ if (!OP_HAS_SIBLING(dynamic_meth))
+ dynamic_meth->op_sibling = (OP*)methop;
+#endif
}
else {
assert(const_meth);
methop->op_next = (OP*)methop;
}
- methop->op_type = (OPCODE)type;
- methop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(methop, type);
methop = (METHOP*) CHECKOP(type, methop);
if (methop->op_next) return (OP*)methop;
=for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
Constructs, checks, and returns an op of method type with a constant
-method name. I<type> is the opcode. I<flags> gives the eight bits of
+method name. I<type> is the opcode. I<flags> gives the eight bits of
C<op_flags>, and, shifted up eight bits, the eight bits of
-C<op_private>. I<const_meth> supplies a constant method name;
+C<op_private>. I<const_meth> supplies a constant method name;
it must be a shared COW string.
Supported optypes: OP_METHOD_NAMED.
if (!first)
first = newOP(OP_NULL, 0);
- binop->op_type = (OPCODE)type;
- binop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(binop, type);
binop->op_first = first;
binop->op_flags = (U8)(flags | OPf_KIDS);
if (!last) {
UV tfirst = 1;
UV tlast = 0;
IV tdiff;
+ STRLEN tcount = 0;
UV rfirst = 1;
UV rlast = 0;
IV rdiff;
+ STRLEN rcount = 0;
IV diff;
I32 none = 0;
U32 max = 0;
/* now see which range will peter our first, if either. */
tdiff = tlast - tfirst;
rdiff = rlast - rfirst;
+ tcount += tdiff + 1;
+ rcount += rdiff + 1;
if (tdiff <= rdiff)
diff = tdiff;
(void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
newSVuv((UV)final), 0);
- if (grows)
- o->op_private |= OPpTRANS_GROWS;
-
Safefree(tsave);
Safefree(rsave);
- op_free(expr);
- op_free(repl);
- return o;
+ tlen = tcount;
+ rlen = rcount;
+ if (r < rend)
+ rlen++;
+ else if (rlast == 0xffffffff)
+ rlen = 0;
+
+ goto warnins;
}
tbl = (short*)PerlMemShared_calloc(
}
}
+ warnins:
if(del && rlen == tlen) {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
} else if(rlen > tlen && !complement) {
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
NewOp(1101, pmop, 1, PMOP);
- pmop->op_type = (OPCODE)type;
- pmop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(pmop, type);
pmop->op_flags = (U8)flags;
pmop->op_private = (U8)(0 | (flags >> 8));
return CHECKOP(type, pmop);
}
+static void
+S_set_haseval(pTHX)
+{
+ PADOFFSET i = 1;
+ PL_cv_has_eval = 1;
+ /* Any pad names in scope are potentially lvalues. */
+ for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
+ PADNAME *pn = PAD_COMPNAME_SV(i);
+ if (!pn || !PadnameLEN(pn))
+ continue;
+ if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
+ S_mark_padname_lvalue(aTHX_ pn);
+ }
+}
+
/* Given some sort of match op o, and an expression expr containing a
* pattern, either compile expr into a regex and attach it to o (if it's
* constant), or convert expr into a runtime regcomp op sequence (if it's
}
rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
- rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
| (reglist ? OPf_STACKED : 0);
rcop->op_targ = cv_targ;
/* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
- if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
+ if (PL_hints & HINT_RE_EVAL)
+ S_set_haseval(aTHX);
/* establish postfix order */
if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
}
else {
rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
- rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
rcop->op_private = 1;
/* establish postfix order */
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
NewOp(1101, svop, 1, SVOP);
- svop->op_type = (OPCODE)type;
- svop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(svop, type);
svop->op_sv = sv;
svop->op_next = (OP*)svop;
svop->op_flags = (U8)flags;
return CHECKOP(type, svop);
}
+/*
+=for apidoc Am|OP *|newDEFSVOP|
+
+Constructs and returns an op to access C<$_>, either as a lexical
+variable (if declared as C<my $_>) in the current scope, or the
+global C<$_>.
+
+=cut
+*/
+
+OP *
+Perl_newDEFSVOP(pTHX)
+{
+ const PADOFFSET offset = pad_findmy_pvs("$_", 0);
+ if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
+ return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
+ }
+ else {
+ OP * const o = newOP(OP_PADSV, 0);
+ o->op_targ = offset;
+ return o;
+ }
+}
+
#ifdef USE_ITHREADS
/*
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
NewOp(1101, padop, 1, PADOP);
- padop->op_type = (OPCODE)type;
- padop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(padop, type);
padop->op_padix =
pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, pvop, 1, PVOP);
- pvop->op_type = (OPCODE)type;
- pvop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(pvop, type);
pvop->op_pv = pv;
pvop->op_next = (OP*)pvop;
pvop->op_flags = (U8)flags;
/* Fake up a method call to VERSION */
meth = newSVpvs_share("VERSION");
- veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
+ veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
op_append_elem(OP_LIST,
- op_prepend_elem(OP_LIST, pack, list(version)),
+ op_prepend_elem(OP_LIST, pack, version),
newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
}
}
/* Fake up a method call to import/unimport */
meth = aver
? newSVpvs_share("import") : newSVpvs_share("unimport");
- imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
+ imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
op_append_elem(OP_LIST,
- op_prepend_elem(OP_LIST, pack, list(arg)),
- newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
+ op_prepend_elem(OP_LIST, pack, arg),
+ newMETHOP_named(OP_METHOD_NAMED, 0, meth)
+ ));
}
/* Fake up the BEGIN {}, which does its thing immediately. */
PL_hints |= HINT_BLOCK_SCOPE;
PL_parser->copline = NOLINE;
- PL_cop_seqmax++; /* Purely for B::*'s benefit */
- if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
- PL_cop_seqmax++;
-
+ COP_SEQMAX_INC; /* Purely for B::*'s benefit */
}
/*
}
/*
- Helper function for newASSIGNOP to detection commonality between the
+ Helper function for newASSIGNOP to detect commonality between the
lhs and the rhs. (It is actually called very indirectly. newASSIGNOP
flags the op and the peephole optimizer calls this helper function
if the flag is set.) Marks all variables with PL_generation. If it
NewOp(1101, cop, 1, COP);
if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
- cop->op_type = OP_DBSTATE;
- cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
+ CHANGE_TYPE(cop, OP_DBSTATE);
}
else {
- cop->op_type = OP_NEXTSTATE;
- cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
+ CHANGE_TYPE(cop, OP_NEXTSTATE);
}
cop->op_flags = (U8)flags;
CopHINTS_set(cop, PL_hints);
-#ifdef NATIVE_HINTS
- cop->op_private |= NATIVE_HINTS;
-#endif
#ifdef VMS
if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
#endif
other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
- logop->op_ppaddr = PL_ppaddr[type];
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
return live;
}
logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
- logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
logop->op_next = LINKLIST(falseop);
PERL_ARGS_ASSERT_NEWRANGE;
range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
- range->op_ppaddr = PL_ppaddr[OP_RANGE];
range->op_flags = OPf_KIDS;
leftstart = LINKLIST(left);
range->op_private = (U8)(1 | (flags >> 8));
left->op_next = flip;
right->op_next = flop;
- range->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);
+ range->op_targ =
+ pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
- flip->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);;
+ flip->op_targ =
+ pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
SvPADTMP_on(PAD_SV(flip->op_targ));
if (!loop) {
NewOp(1101,loop,1,LOOP);
- loop->op_type = OP_ENTERLOOP;
- loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
+ CHANGE_TYPE(loop, OP_ENTERLOOP);
loop->op_private = 0;
loop->op_next = (OP*)loop;
}
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
- sv->op_type = OP_RV2GV;
- sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
+ CHANGE_TYPE(sv, OP_RV2GV);
/* The op_type check is needed to prevent a possible segfault
* if the loop variable is undeclared and 'strict vars' is in
expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
}
- loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
+ loop = (LOOP*)list(op_convert_list(OP_ENTERITER, iterflags,
op_append_elem(OP_LIST, expr, scalar(sv))));
assert(!loop->op_next);
/* for my $x () sets OPpLVAL_INTRO;
PERL_ARGS_ASSERT_NEWGIVWHENOP;
enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
- enterop->op_ppaddr = PL_ppaddr[enter_opcode];
enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
enterop->op_private = 0;
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
- * Can be called in 3 ways:
+ * Can be called in 2 ways:
*
- * !cv
+ * !allow_lex
* look for a single OP_CONST with attached value: return the value
*
- * cv && CvCLONE(cv) && !CvCONST(cv)
+ * allow_lex && !CvCONST(cv);
*
* examine the clone prototype, and if contains only a single
- * OP_CONST referencing a pad const, or a single PADSV referencing
- * an outer lexical, return a non-zero value to indicate the CV is
- * a candidate for "constizing" at clone time
- *
- * cv && CvCONST(cv)
- *
- * We have just cloned an anon prototype that was marked as a const
- * candidate. Try to grab the current value, and in the case of
- * PADSV, ignore it if it has multiple references. In this case we
- * return a newly created *copy* of the value.
+ * OP_CONST, return the value; or if it contains a single PADSV ref-
+ * erencing an outer lexical, turn on CvCONST to indicate the CV is
+ * a candidate for "constizing" at clone time, and return NULL.
*/
-SV *
-Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
+static SV *
+S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
{
SV *sv = NULL;
+ bool padsv = FALSE;
- if (!o)
- return NULL;
-
- if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
- o = OP_SIBLING(cLISTOPo->op_first);
+ assert(o);
+ assert(cv);
for (; o; o = o->op_next) {
const OPCODE type = o->op_type;
- if (sv && o->op_next == o)
- return sv;
- if (o->op_next != o) {
- if (type == OP_NEXTSTATE
- || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
+ if (type == OP_NEXTSTATE || type == OP_LINESEQ
+ || type == OP_NULL
|| type == OP_PUSHMARK)
continue;
- if (type == OP_DBSTATE)
+ if (type == OP_DBSTATE)
continue;
- }
- if (type == OP_LEAVESUB || type == OP_RETURN)
+ if (type == OP_LEAVESUB)
break;
if (sv)
return NULL;
sv = newSV(0);
SAVEFREESV(sv);
}
- else if (cv && type == OP_CONST) {
- sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
- if (!sv)
- return NULL;
- }
- else if (cv && type == OP_PADSV) {
- if (CvCONST(cv)) { /* newly cloned anon */
- sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
- /* the candidate should have 1 ref from this pad and 1 ref
- * from the parent */
- if (!sv || SvREFCNT(sv) != 2)
- return NULL;
- sv = newSVsv(sv);
- SvREADONLY_on(sv);
- return sv;
- }
- else {
+ else if (allow_lex && type == OP_PADSV) {
if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+ {
sv = &PL_sv_undef; /* an arbitrary non-null value */
- }
+ padsv = TRUE;
+ }
+ else
+ return NULL;
}
else {
return NULL;
}
}
+ if (padsv) {
+ CvCONST_on(cv);
+ return NULL;
+ }
return sv;
}
CV *clonee = NULL;
HEK *hek = NULL;
bool reusable = FALSE;
+ OP *start;
+#ifdef PERL_DEBUG_READONLY_OPS
+ OPSLAB *slab = NULL;
+#endif
PERL_ARGS_ASSERT_NEWMYSUB;
spot = (CV **)(svspot = &mg->mg_obj);
}
+ if (block) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ const line_t l = PL_parser->copline;
+ op_free(block);
+ block = newSTATEOP(0, NULL, 0);
+ PL_parser->copline = l;
+ }
+ block = CvLVALUE(compcv)
+ || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ start = LINKLIST(block);
+ block->op_next = 0;
+ }
+
if (!block || !ps || *ps || attrs
- || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
+ || CvLVALUE(compcv)
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
CvXSUB(cv) = const_sv_xsub;
CvCONST_on(cv);
CvISXSUB_on(cv);
+ PoisonPADLIST(cv);
+ CvFLAGS(cv) |= CvMETHOD(compcv);
op_free(block);
SvREFCNT_dec(compcv);
PL_compcv = NULL;
CvFLAGS(compcv) | preserved_flags;
CvOUTSIDE(cv) = CvOUTSIDE(compcv);
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
- CvPADLIST(cv) = CvPADLIST(compcv);
+ CvPADLIST_set(cv, CvPADLIST(compcv));
CvOUTSIDE(compcv) = temp_cv;
- CvPADLIST(compcv) = temp_padl;
+ CvPADLIST_set(compcv, temp_padl);
CvSTART(cv) = CvSTART(compcv);
CvSTART(compcv) = cvstart;
CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
exit. */
PL_breakable_sub_gen++;
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
- OP* const newblock = newSTATEOP(0, NULL, 0);
- op_free(block);
- block = newblock;
- }
- CvROOT(cv) = CvLVALUE(cv)
- ? newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV))
- : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvROOT(cv) = block;
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
/* The cv no longer needs to hold a refcount on the slab, as CvROOT
itself has a refcount. */
CvSLABBED_off(cv);
OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+#ifdef PERL_DEBUG_READONLY_OPS
+ slab = (OPSLAB *)CvSTART(cv);
+#endif
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
finalize_optree(CvROOT(cv));
S_prune_chain_head(&CvSTART(cv));
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
- if (CvCLONE(cv)) {
- assert(!CvCONST(cv));
- if (ps && !*ps && op_const_sv(block, cv))
- CvCONST_on(cv);
- }
-
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
+#ifdef PERL_DEBUG_READONLY_OPS
+ if (slab)
+ Slab_to_ro(slab);
+#endif
if (o) op_free(o);
return cv;
}
o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
bool has_name;
bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
+ OP *start;
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
bool special = FALSE;
? (CV *)SvRV(gv)
: NULL;
+ if (block) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ const line_t l = PL_parser->copline;
+ op_free(block);
+ block = newSTATEOP(0, NULL, 0);
+ PL_parser->copline = l;
+ }
+ block = CvLVALUE(PL_compcv)
+ || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
+ && (!isGV(gv) || !GvASSUMECV(gv)))
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ start = LINKLIST(block);
+ block->op_next = 0;
+ }
if (!block || !ps || *ps || attrs
- || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+ || CvLVALUE(PL_compcv)
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv =
+ S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
assert (block);
CvXSUB(cv) = const_sv_xsub;
CvCONST_on(cv);
CvISXSUB_on(cv);
+ PoisonPADLIST(cv);
+ CvFLAGS(cv) |= CvMETHOD(PL_compcv);
}
else {
- if (isGV(gv)) {
- if (name) GvCV_set(gv, NULL);
+ if (isGV(gv) || CvMETHOD(PL_compcv)) {
+ if (name && isGV(gv))
+ GvCV_set(gv, NULL);
cv = newCONSTSUB_flags(
NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
const_sv
);
+ CvFLAGS(cv) |= CvMETHOD(PL_compcv);
}
else {
if (!SvROK(gv)) {
| CvNAMED(cv);
CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
- CvPADLIST(cv) = CvPADLIST(PL_compcv);
+ CvPADLIST_set(cv,CvPADLIST(PL_compcv));
CvOUTSIDE(PL_compcv) = temp_cv;
- CvPADLIST(PL_compcv) = temp_av;
+ CvPADLIST_set(PL_compcv, temp_av);
CvSTART(cv) = CvSTART(PL_compcv);
CvSTART(PL_compcv) = cvstart;
CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
exit. */
PL_breakable_sub_gen++;
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
- OP* const newblock = newSTATEOP(0, NULL, 0);
- op_free(block);
- block = newblock;
- }
- CvROOT(cv) = CvLVALUE(cv)
- ? newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV))
- : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvROOT(cv) = block;
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
/* The cv no longer needs to hold a refcount on the slab, as CvROOT
#ifdef PERL_DEBUG_READONLY_OPS
slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
finalize_optree(CvROOT(cv));
S_prune_chain_head(&CvSTART(cv));
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
- if (CvCLONE(cv)) {
- assert(!CvCONST(cv));
- if (ps && !*ps && op_const_sv(block, cv))
- CvCONST_on(cv);
- }
-
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
LEAVE_SCOPE(floor);
#ifdef PERL_DEBUG_READONLY_OPS
/* Watch out for BEGIN blocks */
- if (!special) Slab_to_ro(slab);
+ if (!special && slab)
+ Slab_to_ro(slab);
#endif
return cv;
}
return cv;
}
+/*
+=for apidoc U||newXS
+
+Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
+static storage, as it is used directly as CvFILE(), without a copy being made.
+
+=cut
+*/
+
+CV *
+Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
+{
+ PERL_ARGS_ASSERT_NEWXS;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
+ );
+}
+
CV *
Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
const char *const filename, const char *const proto,
}
CV *
+Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
+{
+ PERL_ARGS_ASSERT_NEWXS_DEFFILE;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
+ );
+}
+
+CV *
Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
XSUBADDR_t subaddr, const char *const filename,
const char *const proto, SV **const_svp,
bool interleave = FALSE;
PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
-
+ if (!subaddr)
+ Perl_croak_nocontext("panic: no address for '%s' in '%s'",
+ name, filename ? filename : PL_xsubfilename);
{
GV * const gv = gv_fetchpvn(
name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
name ? len : PL_curstash ? sizeof("__ANON__") - 1:
sizeof("__ANON__::__ANON__") - 1,
GV_ADDMULTI | flags, SVt_PVCV);
-
- if (!subaddr)
- Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
-
+
if ((cv = (name ? GvCV(gv) : NULL))) {
if (GvCVGEN(gv)) {
/* just a cached method */
gv_method_changed(gv); /* newXS */
}
}
- if (!name)
- CvANON_on(cv);
+
CvGV_set(cv, gv);
- (void)gv_fetchfile(filename);
- CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
- an external constant string */
- assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+ if(filename) {
+ (void)gv_fetchfile(filename);
+ assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+ if (flags & XS_DYNAMIC_FILENAME) {
+ CvDYNFILE_on(cv);
+ CvFILE(cv) = savepv(filename);
+ } else {
+ /* NOTE: not copied, as it is expected to be an external constant string */
+ CvFILE(cv) = (char *)filename;
+ }
+ } else {
+ assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
+ CvFILE(cv) = (char*)PL_xsubfilename;
+ }
CvISXSUB_on(cv);
CvXSUB(cv) = subaddr;
-
+#ifndef PERL_IMPLICIT_CONTEXT
+ CvHSCXT(cv) = &PL_stack_sp;
+#else
+ PoisonPADLIST(cv);
+#endif
+
if (name)
process_special_blocks(0, name, gv, cv);
- }
+ else
+ CvANON_on(cv);
+ } /* <- not a conditional branch */
+
- if (flags & XS_DYNAMIC_FILENAME) {
- CvFILE(cv) = savepv(filename);
- CvDYNFILE_on(cv);
- }
sv_setpv(MUTABLE_SV(cv), proto);
if (interleave) LEAVE;
return cv;
return cv;
}
-/*
-=for apidoc U||newXS
-
-Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
-static storage, as it is used directly as CvFILE(), without a copy being made.
-
-=cut
-*/
-
-CV *
-Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
-{
- PERL_ARGS_ASSERT_NEWXS;
- return newXS_len_flags(
- name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
- );
-}
-
void
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
OP *
Perl_newANONLIST(pTHX_ OP *o)
{
- return convert(OP_ANONLIST, OPf_SPECIAL, o);
+ return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
}
OP *
Perl_newANONHASH(pTHX_ OP *o)
{
- return convert(OP_ANONHASH, OPf_SPECIAL, o);
+ return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
}
OP *
switch (o->op_type) {
case OP_PADSV:
case OP_PADHV:
- o->op_type = OP_PADAV;
- o->op_ppaddr = PL_ppaddr[OP_PADAV];
+ CHANGE_TYPE(o, OP_PADAV);
return ref(o, OP_RV2AV);
case OP_RV2SV:
case OP_RV2HV:
- o->op_type = OP_RV2AV;
- o->op_ppaddr = PL_ppaddr[OP_RV2AV];
+ CHANGE_TYPE(o, OP_RV2AV);
ref(o, OP_RV2AV);
break;
switch (o->op_type) {
case OP_PADSV:
case OP_PADAV:
- o->op_type = OP_PADHV;
- o->op_ppaddr = PL_ppaddr[OP_PADHV];
+ CHANGE_TYPE(o, OP_PADHV);
return ref(o, OP_RV2HV);
case OP_RV2SV:
case OP_RV2AV:
- o->op_type = OP_RV2HV;
- o->op_ppaddr = PL_ppaddr[OP_RV2HV];
+ CHANGE_TYPE(o, OP_RV2HV);
ref(o, OP_RV2HV);
break;
PERL_ARGS_ASSERT_NEWAVREF;
if (o->op_type == OP_PADANY) {
- o->op_type = OP_PADAV;
- o->op_ppaddr = PL_ppaddr[OP_PADAV];
+ CHANGE_TYPE(o, OP_PADAV);
return o;
}
else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
PERL_ARGS_ASSERT_NEWHVREF;
if (o->op_type == OP_PADANY) {
- o->op_type = OP_PADHV;
- o->op_ppaddr = PL_ppaddr[OP_PADHV];
+ CHANGE_TYPE(o, OP_PADHV);
return o;
}
else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
{
if (o->op_type == OP_PADANY) {
dVAR;
- o->op_type = OP_PADCV;
- o->op_ppaddr = PL_ppaddr[OP_PADCV];
+ CHANGE_TYPE(o, OP_PADCV);
}
return newUNOP(OP_RV2CV, flags, scalar(o));
}
PERL_ARGS_ASSERT_NEWSVREF;
if (o->op_type == OP_PADANY) {
- o->op_type = OP_PADSV;
- o->op_ppaddr = PL_ppaddr[OP_PADSV];
+ CHANGE_TYPE(o, OP_PADSV);
return o;
}
return newUNOP(OP_RV2SV, 0, scalar(o));
op_free(o);
enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
- enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
/* establish postfix order */
enter->op_next = (OP*)enter;
o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
- o->op_type = OP_LEAVETRY;
- o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
+ CHANGE_TYPE(o, OP_LEAVETRY);
enter->op_other = o;
return o;
}
else {
scalar((OP*)kid);
- PL_cv_has_eval = 1;
+ S_set_haseval(aTHX);
}
}
else {
&& SvTYPE(SvRV(gv)) != SVt_PVCV)
gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
}
- kid->op_type = OP_GV;
+ CHANGE_TYPE(kid, OP_GV);
SvREFCNT_dec(kid->op_sv);
#ifdef USE_ITHREADS
/* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
kid->op_sv = SvREFCNT_inc_simple_NN(gv);
#endif
kid->op_private = 0;
- kid->op_ppaddr = PL_ppaddr[OP_GV];
/* FAKE globs in the symbol table cause weird bugs (#77810) */
SvFAKE_off(gv);
}
PERL_ARGS_ASSERT_CK_GREP;
- o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
/* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
if (o->op_flags & OPf_STACKED) {
kid = kUNOP->op_first;
gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
- gwop->op_ppaddr = PL_ppaddr[type];
kid->op_next = (OP*)gwop;
offset = pad_findmy_pvs("$_", 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
/* Implicitly take a reference to a regular expression */
if (first->op_type == OP_MATCH) {
- first->op_type = OP_QR;
- first->op_ppaddr = PL_ppaddr[OP_QR];
+ CHANGE_TYPE(first, OP_QR);
}
if (second->op_type == OP_MATCH) {
- second->op_type = OP_QR;
- second->op_ppaddr = PL_ppaddr[OP_QR];
+ CHANGE_TYPE(second, OP_QR);
}
}
}
-OP *
-Perl_ck_sassign(pTHX_ OP *o)
+static OP *
+S_maybe_targlex(pTHX_ OP *o)
{
dVAR;
OP * const kid = cLISTOPo->op_first;
-
- PERL_ARGS_ASSERT_CK_SASSIGN;
-
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
&& !(kid->op_flags & OPf_STACKED)
/* Can just relocate the target. */
if (kkid && kkid->op_type == OP_PADSV
- && !(kkid->op_private & OPpLVAL_INTRO))
+ && (!(kkid->op_private & OPpLVAL_INTRO)
+ || kkid->op_private & OPpPAD_STATE))
{
kid->op_targ = kkid->op_targ;
kkid->op_targ = 0;
/* Now we do not need PADSV and SASSIGN.
- * first replace the PADSV with OP_SIBLING(o), then
- * detach kid and OP_SIBLING(o) from o */
- op_sibling_splice(o, kid, 1, OP_SIBLING(o));
- op_sibling_splice(o, NULL, -1, NULL);
+ * Detach kid and free the rest. */
+ op_sibling_splice(o, NULL, 1, NULL);
op_free(o);
- op_free(kkid);
kid->op_private |= OPpTARGET_MY; /* Used for context settings */
return kid;
}
}
+ return o;
+}
+
+OP *
+Perl_ck_sassign(pTHX_ OP *o)
+{
+ dVAR;
+ OP * const kid = cLISTOPo->op_first;
+
+ PERL_ARGS_ASSERT_CK_SASSIGN;
+
if (OP_HAS_SIBLING(kid)) {
OP *kkid = OP_SIBLING(kid);
- /* For state variable assignment, kkid is a list op whose op_last
- is a padsv. */
+ /* For state variable assignment with attributes, kkid is a list op
+ whose op_last is a padsv. */
if ((kkid->op_type == OP_PADSV ||
(OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
(kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
)
)
- && (kkid->op_private & OPpLVAL_INTRO)
- && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) {
+ && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
+ == (OPpLVAL_INTRO|OPpPAD_STATE)) {
const PADOFFSET target = kkid->op_targ;
OP *const other = newOP(OP_PADSV,
kkid->op_flags
| ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
OP *const first = newOP(OP_NULL, 0);
- OP *const nullop = newCONDOP(0, first, o, other);
+ OP *const nullop =
+ newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
OP *const condop = first->op_next;
- condop->op_type = OP_ONCE;
- condop->op_ppaddr = PL_ppaddr[OP_ONCE];
+ CHANGE_TYPE(condop, OP_ONCE);
other->op_targ = target;
/* Store the initializedness of state vars in a separate
return nullop;
}
}
- return o;
+ return S_maybe_targlex(aTHX_ o);
}
OP *
{
OP * const right = cLISTOPo->op_first;
OP * const left = OP_SIBLING(right);
- OP * const varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
+ OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
bool stacked = 0;
PERL_ARGS_ASSERT_CK_REFASSIGN;
assert (left);
assert (left->op_type == OP_SREFGEN);
+ o->op_private = varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
+
switch (varop->op_type) {
case OP_PADAV:
- o->op_private = OPpLVREF_AV;
+ o->op_private |= OPpLVREF_AV;
goto settarg;
case OP_PADHV:
- o->op_private = OPpLVREF_HV;
+ o->op_private |= OPpLVREF_HV;
case OP_PADSV:
settarg:
o->op_targ = varop->op_targ;
PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
break;
case OP_RV2AV:
- o->op_private = OPpLVREF_AV;
+ o->op_private |= OPpLVREF_AV;
goto checkgv;
case OP_RV2HV:
- o->op_private = OPpLVREF_HV;
+ o->op_private |= OPpLVREF_HV;
case OP_RV2SV:
checkgv:
if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
- goto null_and_stack;
+ detach_and_stack:
+ /* Point varop to its GV kid, detached. */
+ varop = op_sibling_splice(varop, NULL, -1, NULL);
+ stacked = TRUE;
+ break;
case OP_RV2CV: {
- OP * const kid =
- cUNOPx(cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling)
- ->op_first;
- o->op_private = OPpLVREF_CV;
- if (kid->op_type == OP_GV) goto null_and_stack;
+ OP * const kidparent =
+ cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling;
+ OP * const kid = cUNOPx(kidparent)->op_first;
+ o->op_private |= OPpLVREF_CV;
+ if (kid->op_type == OP_GV) {
+ varop = kidparent;
+ goto detach_and_stack;
+ }
if (kid->op_type != OP_PADCV) goto bad;
o->op_targ = kid->op_targ;
kid->op_targ = 0;
}
case OP_AELEM:
case OP_HELEM:
- o->op_private = OPpLVREF_ELEM;
- null_and_stack:
+ o->op_private |= OPpLVREF_ELEM;
op_null(varop);
- op_null(left);
stacked = TRUE;
+ /* Detach varop. */
+ op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
break;
default:
bad:
Perl_ck_warner_d(aTHX_
packWARN(WARN_EXPERIMENTAL__REFALIASING),
"Aliasing via reference is experimental");
- o->op_private |= varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
- if (stacked) o->op_flags |= OPf_STACKED;
+ if (stacked) {
+ o->op_flags |= OPf_STACKED;
+ op_sibling_splice(o, right, 1, varop);
+ }
else {
o->op_flags &=~ OPf_STACKED;
op_sibling_splice(o, right, 1, NULL);
- op_free(left);
}
+ op_free(left);
return o;
}
if (cBINOPo->op_first->op_flags & OPf_PARENS) {
OP* kids;
o->op_private |= OPpREPEAT_DOLIST;
- kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */
- kids = force_list(kids, 1); /* promote them to a list */
+ kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
+ kids = force_list(kids, 1); /* promote it to a list */
op_sibling_splice(o, NULL, 0, kids); /* and add back */
- if (cBINOPo->op_last == kids) cBINOPo->op_last = NULL;
}
else
scalar(o);
if (o->op_flags & OPf_KIDS) {
kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
if (kid && OP_HAS_SIBLING(kid)) {
- o->op_type = OP_SSELECT;
- o->op_ppaddr = PL_ppaddr[OP_SSELECT];
+ CHANGE_TYPE(o, OP_SSELECT);
o = ck_fun(o);
return fold_constants(op_integerize(op_std_init(o)));
}
OP * const padop = newOP(OP_PADCV, 0);
padop->op_targ = off;
cUNOPx(firstkid)->op_first = padop;
+#ifdef PERL_OP_PARENT
+ padop->op_sibling = firstkid;
+#endif
op_free(kid);
}
}
kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
op_sibling_splice(o, NULL, 0, kid);
}
-
- kid->op_type = OP_PUSHRE;
- kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
+ CHANGE_TYPE(kid, OP_PUSHRE);
scalar(kid);
if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
{
OP * const kid = OP_SIBLING(cUNOPo->op_first);
PERL_ARGS_ASSERT_CK_STRINGIFY;
- if (kid->op_type == OP_JOIN) {
+ if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
+ || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
+ || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
+ {
assert(!OP_HAS_SIBLING(kid));
op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
op_free(o);
if (bairn && !OP_HAS_SIBLING(bairn) /* single-item list */
&& PL_opargs[bairn->op_type] & OA_RETSCALAR)
{
- OP * const ret = convert(OP_STRINGIFY, 0,
+ OP * const ret = op_convert_list(OP_STRINGIFY, 0,
op_sibling_splice(o, kid, 1, NULL));
op_free(o);
ret->op_folded = 1;
? newPVOP(OP_RUNCV,0,NULL)
: newOP(opnum,0);
default:
- return convert(opnum,0,aop);
+ return op_convert_list(opnum,0,aop);
}
}
assert(0);
#define IS_OR_OP(o) (o->op_type == OP_OR)
-STATIC void
-S_null_listop_in_list_context(pTHX_ OP *o)
-{
- PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
-
- /* This is an OP_LIST in list (or void) context. That means we
- * can ditch the OP_LIST and the OP_PUSHMARK within. */
-
- op_null(cUNOPo->op_first); /* NULL the pushmark */
- op_null(o); /* NULL the list */
-}
-
/* A peephole optimizer. We visit the ops in the order they're to execute.
* See the comments at the top of this file for more details about when
* peep() is called */
PL_op = o;
- /* The following will have the OP_LIST and OP_PUSHMARK
- * patched out later IF the OP_LIST is in list context, or
- * if it is in void context and padrange is not possible.
- * So in that case, we can set the this OP's op_next
- * to skip to after the OP_PUSHMARK:
- * a THIS -> b
- * d list -> e
- * b pushmark -> c
- * c whatever -> d
- * e whatever
- * will eventually become:
- * a THIS -> c
- * - ex-list -> -
- * - ex-pushmark -> -
- * c whatever -> e
- * e whatever
- */
- {
- OP *sibling;
- OP *other_pushmark;
- OP *pushsib;
- if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
- && (sibling = OP_SIBLING(o))
- && sibling->op_type == OP_LIST
- /* This KIDS check is likely superfluous since OP_LIST
- * would otherwise be an OP_STUB. */
- && sibling->op_flags & OPf_KIDS
- && (other_pushmark = cLISTOPx(sibling)->op_first)
- /* Pointer equality also effectively checks that it's a
- * pushmark. */
- && other_pushmark == o->op_next
- /* List context */
- && ( (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
- /* ... or void context... */
- || ( (sibling->op_flags & OPf_WANT) == OPf_WANT_VOID
- /* ...and something padrange would reject */
- && ( !(pushsib = OP_SIBLING(other_pushmark))
- || ( pushsib->op_type != OP_PADSV
- && pushsib->op_type != OP_PADAV
- && pushsib->op_type != OP_PADHV)
- || pushsib->op_private & ~OPpLVAL_INTRO))
- ))
- {
- o->op_next = other_pushmark->op_next;
- null_listop_in_list_context(sibling);
- }
- }
-
switch (o->op_type) {
case OP_DBSTATE:
PL_curcop = ((COP*)o); /* for warnings */
if ( OP_TYPE_IS(next, OP_PUSHMARK)
&& OP_TYPE_IS(sibling, OP_RETURN)
&& OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
- && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
+ && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
+ ||OP_TYPE_IS(sibling->op_next->op_next,
+ OP_LEAVESUBLV))
&& cUNOPx(sibling)->op_first == next
&& OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next
&& next->op_next
case OP_PUSHMARK:
+ /* Given
+ 5 repeat/DOLIST
+ 3 ex-list
+ 1 pushmark
+ 2 scalar or const
+ 4 const[0]
+ convert repeat into a stub with no kids.
+ */
+ if (o->op_next->op_type == OP_CONST
+ || ( o->op_next->op_type == OP_PADSV
+ && !(o->op_next->op_private & OPpLVAL_INTRO))
+ || ( o->op_next->op_type == OP_GV
+ && o->op_next->op_next->op_type == OP_RV2SV
+ && !(o->op_next->op_next->op_private
+ & (OPpLVAL_INTRO|OPpOUR_INTRO))))
+ {
+ const OP *kid = o->op_next->op_next;
+ if (o->op_next->op_type == OP_GV)
+ kid = kid->op_next;
+ /* kid is now the ex-list. */
+ if (kid->op_type == OP_NULL
+ && (kid = kid->op_next)->op_type == OP_CONST
+ /* kid is now the repeat count. */
+ && kid->op_next->op_type == OP_REPEAT
+ && kid->op_next->op_private & OPpREPEAT_DOLIST
+ && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
+ && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
+ {
+ o = kid->op_next; /* repeat */
+ assert(oldop);
+ oldop->op_next = o;
+ op_free(cBINOPo->op_first);
+ op_free(cBINOPo->op_last );
+ o->op_flags &=~ OPf_KIDS;
+ /* stub is a baseop; repeat is a binop */
+ assert(sizeof(OP) <= sizeof(BINOP));
+ CHANGE_TYPE(o, OP_STUB);
+ o->op_private = 0;
+ break;
+ }
+ }
+
/* Convert a series of PAD ops for my vars plus support into a
* single padrange op. Basically
*
/* look for a pushmark -> gv[_] -> rv2av */
{
- GV *gv;
OP *rv2av, *q;
p = o->op_next;
if ( p->op_type == OP_GV
- && (gv = cGVOPx_gv(p)) && isGV(gv)
- && GvNAMELEN_get(gv) == 1
- && *GvNAME_get(gv) == '_'
- && GvSTASH(gv) == PL_defstash
+ && cGVOPx_gv(p) == PL_defgv
&& (rv2av = p->op_next)
&& rv2av->op_type == OP_RV2AV
&& !(rv2av->op_flags & OPf_REF)
&& !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
&& ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
- && OP_SIBLING(o) == rv2av /* these two for Deparse */
- && cUNOPx(rv2av)->op_first == p
) {
q = rv2av->op_next;
if (q->op_type == OP_NULL)
}
}
if (!defav) {
- /* To allow Deparse to pessimise this, it needs to be able
- * to restore the pushmark's original op_next, which it
- * will assume to be the same as OP_SIBLING. */
- if (o->op_next != OP_SIBLING(o))
- break;
p = o;
}
* *always* formerly a pushmark */
assert(o->op_type == OP_PUSHMARK);
o->op_next = followop;
- o->op_type = OP_PADRANGE;
- o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
+ CHANGE_TYPE(o, OP_PADRANGE);
o->op_targ = base;
/* bit 7: INTRO; bit 6..0: count */
o->op_private = (intro | count);
o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
| OPpOUR_INTRO);
o->op_next = o->op_next->op_next;
- o->op_type = OP_GVSV;
- o->op_ppaddr = PL_ppaddr[OP_GVSV];
+ CHANGE_TYPE(o, OP_GVSV);
}
}
else if (o->op_next->op_type == OP_READLINE
&& (o->op_next->op_next->op_flags & OPf_STACKED))
{
/* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
- o->op_type = OP_RCATLINE;
+ CHANGE_TYPE(o, OP_RCATLINE);
o->op_flags |= OPf_STACKED;
- o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
op_null(o->op_next->op_next);
op_null(o->op_next);
}
break;
case OP_RUNCV:
- if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
+ if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
+ && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
+ {
SV *sv;
if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
else {
sv_rvweaken(sv);
SvREADONLY_on(sv);
}
- o->op_type = OP_CONST;
- o->op_ppaddr = PL_ppaddr[OP_CONST];
+ CHANGE_TYPE(o, OP_CONST);
o->op_flags |= OPf_SPECIAL;
cSVOPo->op_sv = sv;
}
break;
case OP_SASSIGN:
- if (OP_GIMME(o,0) == G_VOID) {
+ if (OP_GIMME(o,0) == G_VOID
+ || ( o->op_next->op_type == OP_LINESEQ
+ && ( o->op_next->op_next->op_type == OP_LEAVESUB
+ || ( o->op_next->op_next->op_type == OP_RETURN
+ && !CvLVALUE(PL_compcv)))))
+ {
OP *right = cBINOP->op_first;
if (right) {
/* sassign
/* We do the common-vars check here, rather than in newASSIGNOP
(as formerly), so that all lexical vars that get aliased are
marked as such before we do the check. */
+ /* There can’t be common vars if the lhs is a stub. */
+ if (OP_SIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
+ == cLISTOPx(cBINOPo->op_last)->op_last
+ && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
+ {
+ o->op_private &=~ OPpASSIGN_COMMON;
+ break;
+ }
if (o->op_private & OPpASSIGN_COMMON) {
/* See the comment before S_aassign_common_vars concerning
PL_generation sorcery. */
}
return o;
default:
- o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
+ o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
if (is_handle_constructor(o, 2))
argop->op_private |= OPpCOREARGS_DEREF2;
if (opnum == OP_SUBSTR) {
in dynamic context */
#define OPpENTERSUB_LVAL_MASK (OPpLVAL_INTRO|OPpENTERSUB_INARGS)
-/* VMS-specific hints in COPs */
-#define OPpHINT_M_VMSISH_MASK (OPpHINT_M_VMSISH_STATUS|OPpHINT_M_VMSISH_TIME)
-
struct op {
#define Perl_pp_keys Perl_do_kv
#define Perl_pp_rv2hv Perl_pp_rv2av
#define Perl_pp_pop Perl_pp_shift
-#define Perl_pp_mapstart Perl_unimplemented_op
+#define Perl_pp_mapstart Perl_pp_grepstart
#define Perl_pp_dor Perl_pp_defined
#define Perl_pp_andassign Perl_pp_and
#define Perl_pp_orassign Perl_pp_or
"join or string",
"list",
"list slice",
- "anonymous list ([])",
+ "anonymous array ([])",
"anonymous hash ({})",
"splice",
"push",
Perl_pp_reverse,
Perl_pp_grepstart,
Perl_pp_grepwhile,
- Perl_pp_mapstart, /* implemented by Perl_unimplemented_op */
+ Perl_pp_mapstart, /* implemented by Perl_pp_grepstart */
Perl_pp_mapwhile,
Perl_pp_range,
Perl_pp_flip,
0x00001104, /* regcmaybe */
0x00001104, /* regcreset */
0x00001304, /* regcomp */
- 0x00000540, /* match */
+ 0x00000500, /* match */
0x00000504, /* qr */
- 0x00001544, /* subst */
- 0x00000344, /* substcont */
+ 0x00001504, /* subst */
+ 0x00000304, /* substcont */
0x00001804, /* trans */
0x00001804, /* transr */
0x00000004, /* sassign */
0x00001144, /* i_preinc */
0x00001164, /* predec */
0x00001144, /* i_predec */
- 0x0000116c, /* postinc */
- 0x0000115c, /* i_postinc */
- 0x0000116c, /* postdec */
- 0x0000115c, /* i_postdec */
+ 0x0000112c, /* postinc */
+ 0x0000110c, /* i_postinc */
+ 0x0000112c, /* postdec */
+ 0x0000110c, /* i_postdec */
0x0001121e, /* pow */
0x0001123e, /* multiply */
0x0001121e, /* i_multiply */
0x0001121e, /* i_divide */
0x0001123e, /* modulo */
0x0001121e, /* i_modulo */
- 0x0001220b, /* repeat */
+ 0x0001221b, /* repeat */
0x0001123e, /* add */
0x0001121e, /* i_add */
0x0001123e, /* subtract */
0x0001120e, /* bit_xor */
0x0001120e, /* bit_or */
0x0000112e, /* negate */
- 0x0000111e, /* i_negate */
+ 0x0000110e, /* i_negate */
0x00001106, /* not */
0x0000110e, /* complement */
0x00000204, /* smartmatch */
0x00009b9e, /* abs */
0x00009b9e, /* length */
0x0991140c, /* substr */
- 0x0011140c, /* vec */
+ 0x0011141c, /* vec */
0x0091141c, /* index */
0x0091141c, /* rindex */
0x0002140f, /* sprintf */
0x00013204, /* aelem */
0x00023401, /* aslice */
0x00023401, /* kvaslice */
- 0x00003b00, /* aeach */
+ 0x00003b40, /* aeach */
0x00003b08, /* akeys */
- 0x00003b08, /* avalues */
- 0x00004b00, /* each */
- 0x00004b08, /* values */
+ 0x00003b48, /* avalues */
+ 0x00004b40, /* each */
+ 0x00004b48, /* values */
0x00004b08, /* keys */
0x00001b00, /* delete */
0x00001b04, /* exists */
0x00024401, /* kvhslice */
0x00091480, /* unpack */
0x0002140f, /* pack */
- 0x00111408, /* split */
+ 0x00111418, /* split */
0x0002140f, /* join */
0x00002401, /* list */
0x00224200, /* lslice */
0x0000bb04, /* pop */
0x0000bb04, /* shift */
0x0002341d, /* unshift */
- 0x0002d441, /* sort */
+ 0x0002d401, /* sort */
0x00002409, /* reverse */
- 0x00025441, /* grepstart */
- 0x00000348, /* grepwhile */
- 0x00025441, /* mapstart */
- 0x00000348, /* mapwhile */
+ 0x00025401, /* grepstart */
+ 0x00000308, /* grepwhile */
+ 0x00025401, /* mapstart */
+ 0x00000308, /* mapwhile */
0x00011300, /* range */
0x00011100, /* flip */
0x00000100, /* flop */
0x00000300, /* or */
0x00011206, /* xor */
0x00000300, /* dor */
- 0x00000340, /* cond_expr */
+ 0x00000300, /* cond_expr */
0x00000304, /* andassign */
0x00000304, /* orassign */
0x00000304, /* dorassign */
0x00000100, /* leavesublv */
0x00009b08, /* caller */
0x0000240d, /* warn */
- 0x0000244d, /* die */
+ 0x0000240d, /* die */
0x00009b04, /* reset */
0x00000400, /* lineseq */
0x00000a04, /* nextstate */
0x00000000, /* iter */
0x00000940, /* enterloop */
0x00000200, /* leaveloop */
- 0x00002441, /* return */
- 0x00000d44, /* last */
- 0x00000d44, /* next */
- 0x00000d44, /* redo */
+ 0x00002401, /* return */
+ 0x00000d04, /* last */
+ 0x00000d04, /* next */
+ 0x00000d04, /* redo */
0x00000d44, /* dump */
- 0x00000d44, /* goto */
- 0x00009b44, /* exit */
+ 0x00000d04, /* goto */
+ 0x00009b04, /* exit */
0x00000e40, /* method_named */
0x00000340, /* entergiven */
0x00000100, /* leavegiven */
0x00096404, /* binmode */
0x00217445, /* tie */
0x00007b04, /* untie */
- 0x00007b04, /* tied */
+ 0x00007b44, /* tied */
0x00114404, /* dbmopen */
0x00004b04, /* dbmclose */
0x01111408, /* sselect */
0x0000e40c, /* select */
0x0000eb0c, /* getc */
0x0917640d, /* read */
- 0x0000eb44, /* enterwrite */
+ 0x0000eb04, /* enterwrite */
0x00000100, /* leavewrite */
0x0002e405, /* prtf */
0x0002e405, /* print */
0x0000001c, /* wait */
0x0001141c, /* waitpid */
0x0002941d, /* system */
- 0x0002945d, /* exec */
- 0x0000245d, /* kill */
+ 0x0002941d, /* exec */
+ 0x0000241d, /* kill */
0x0000001c, /* getppid */
0x00009b1c, /* getpgrp */
0x0009941c, /* setpgrp */
0x00007b04, /* lock */
0x00000300, /* once */
0x00000000, /* custom */
- 0x00001b00, /* reach */
+ 0x00001b40, /* reach */
0x00001b08, /* rkeys */
- 0x00001b08, /* rvalues */
+ 0x00001b48, /* rvalues */
0x00000600, /* coreargs */
0x00000004, /* runcv */
0x00009b8e, /* fc */
#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 OPpDEREF_AV 0x10
#define OPpEVAL_COPHH 0x10
#define OPpFT_AFTER_t 0x10
-#define OPpLVAL_DEFER 0x10
+#define OPpLVREF_AV 0x10
+#define OPpMAYBE_TRUEBOOL 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 OPpDEREF_HV 0x20
#define OPpEARLY_CV 0x20
#define OPpEVAL_RE_REPARSING 0x20
#define OPpHUSH_VMSISH 0x20
-#define OPpLVREF_AV 0x20
+#define OPpLVREF_HV 0x20
+#define OPpMAY_RETURN_CONSTANT 0x20
#define OPpOPEN_IN_CRLF 0x20
#define OPpSORT_QSORT 0x20
#define OPpTRANS_COMPLEMENT 0x20
#define OPpTRUEBOOL 0x20
+#define OPpDEREF 0x30
+#define OPpDEREF_SV 0x30
+#define OPpLVREF_CV 0x30
+#define OPpLVREF_TYPE 0x30
+#define OPpALLOW_FAKE 0x40
#define OPpASSIGN_BACKWARDS 0x40
#define OPpASSIGN_COMMON 0x40
#define OPpCONST_BARE 0x40
#define OPpCOREARGS_SCALARMOD 0x40
-#define OPpDEREF_HV 0x40
+#define OPpENTERSUB_DB 0x40
#define OPpEXISTS_SUB 0x40
#define OPpFLIP_LINENUM 0x40
-#define OPpHINT_M_VMSISH_STATUS 0x40
#define OPpLIST_GUESSED 0x40
-#define OPpLVREF_HV 0x40
-#define OPpMAYBE_TRUEBOOL 0x40
-#define OPpMAY_RETURN_CONSTANT 0x40
+#define OPpLVAL_DEFER 0x40
#define OPpOPEN_OUT_RAW 0x40
+#define OPpOUR_INTRO 0x40
+#define OPpPAD_STATE 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 OPpLVREF_CV 0x60
-#define OPpLVREF_TYPE 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
'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',
};
0, 8, -1,
0, 8, -1,
0, 8, -1,
- 5, -1, 1, 130, 2, 137, 3, 144, -1,
- 5, -1, 0, 481, 1, 26, 2, 250, 3, 83, -1,
+ 4, -1, 1, 130, 2, 137, 3, 144, -1,
+ 4, -1, 0, 481, 1, 26, 2, 250, 3, 83, -1,
};
39, /* av2arylen */
41, /* rv2cv */
-1, /* anoncode */
- 48, /* prototype */
- 49, /* refgen */
- 50, /* srefgen */
- 51, /* ref */
- 52, /* bless */
- 53, /* backtick */
- 58, /* glob */
- 59, /* readline */
+ 0, /* prototype */
+ 0, /* refgen */
+ 0, /* srefgen */
+ 0, /* ref */
+ 48, /* bless */
+ 49, /* backtick */
+ 48, /* glob */
+ 0, /* 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 */
- 103, /* preinc */
- 104, /* i_preinc */
- 105, /* predec */
- 106, /* i_predec */
- 107, /* postinc */
- 108, /* i_postinc */
- 110, /* postdec */
- 111, /* i_postdec */
- 113, /* pow */
- 115, /* multiply */
- 117, /* i_multiply */
- 119, /* divide */
- 121, /* i_divide */
- 123, /* modulo */
- 125, /* i_modulo */
- 127, /* repeat */
- 129, /* add */
- 131, /* i_add */
- 133, /* subtract */
- 135, /* i_subtract */
- 137, /* concat */
- 139, /* stringify */
- 141, /* left_shift */
- 143, /* right_shift */
- 145, /* lt */
- 146, /* i_lt */
- 147, /* gt */
- 148, /* i_gt */
- 149, /* le */
- 150, /* i_le */
- 151, /* ge */
- 152, /* i_ge */
- 153, /* eq */
- 154, /* i_eq */
- 155, /* ne */
- 156, /* i_ne */
- 157, /* ncmp */
- 158, /* i_ncmp */
- 159, /* slt */
- 160, /* sgt */
- 161, /* sle */
- 162, /* sge */
- 163, /* seq */
- 164, /* sne */
- 165, /* scmp */
- 166, /* bit_and */
- 167, /* bit_xor */
- 168, /* bit_or */
- 169, /* negate */
- 170, /* i_negate */
- 172, /* not */
- 173, /* complement */
- 174, /* smartmatch */
- 175, /* atan2 */
- 177, /* sin */
- 179, /* cos */
- 181, /* rand */
- 183, /* srand */
- 185, /* exp */
- 187, /* log */
- 189, /* sqrt */
- 191, /* int */
- 193, /* hex */
- 195, /* oct */
- 197, /* abs */
- 199, /* length */
- 201, /* substr */
- 204, /* vec */
- 206, /* index */
- 208, /* rindex */
- 210, /* sprintf */
- 211, /* formline */
- 212, /* ord */
- 214, /* chr */
- 216, /* crypt */
- 218, /* ucfirst */
- 219, /* lcfirst */
- 220, /* uc */
- 221, /* lc */
- 222, /* quotemeta */
- 223, /* rv2av */
- 229, /* aelemfast */
- 230, /* aelemfast_lex */
- 231, /* aelem */
- 236, /* aslice */
- 239, /* kvaslice */
- 240, /* aeach */
- 241, /* akeys */
- 242, /* avalues */
- 243, /* each */
- 244, /* values */
- 245, /* keys */
- 247, /* delete */
- 250, /* exists */
- 252, /* rv2hv */
- 260, /* helem */
- 265, /* hslice */
- 268, /* kvhslice */
- 269, /* unpack */
- 270, /* pack */
- 271, /* split */
- 273, /* join */
- 274, /* list */
- 276, /* lslice */
- 277, /* anonlist */
- 278, /* anonhash */
- 279, /* splice */
- 280, /* push */
- 282, /* pop */
- 283, /* shift */
- 284, /* unshift */
- 286, /* sort */
- 293, /* reverse */
- 295, /* grepstart */
- 296, /* grepwhile */
- 298, /* mapstart */
- 299, /* mapwhile */
- 301, /* range */
- 302, /* flip */
- 304, /* flop */
- 306, /* and */
- 307, /* or */
- 308, /* xor */
- 309, /* dor */
- 310, /* cond_expr */
- 312, /* andassign */
- 313, /* orassign */
- 314, /* dorassign */
- 315, /* method */
- 316, /* entersub */
- 323, /* leavesub */
- 325, /* leavesublv */
- 327, /* caller */
- 329, /* warn */
- 330, /* die */
- 331, /* reset */
+ 0, /* regcmaybe */
+ 0, /* regcreset */
+ 0, /* regcomp */
+ 54, /* match */
+ 26, /* qr */
+ 54, /* subst */
+ 56, /* substcont */
+ 58, /* trans */
+ 58, /* transr */
+ 66, /* sassign */
+ 69, /* aassign */
+ 0, /* chop */
+ 0, /* schop */
+ 72, /* chomp */
+ 72, /* schomp */
+ 0, /* defined */
+ 0, /* undef */
+ 0, /* study */
+ 39, /* pos */
+ 0, /* preinc */
+ 0, /* i_preinc */
+ 0, /* predec */
+ 0, /* i_predec */
+ 0, /* postinc */
+ 0, /* i_postinc */
+ 0, /* postdec */
+ 0, /* i_postdec */
+ 74, /* pow */
+ 74, /* multiply */
+ 74, /* i_multiply */
+ 74, /* divide */
+ 74, /* i_divide */
+ 74, /* modulo */
+ 74, /* i_modulo */
+ 76, /* repeat */
+ 74, /* add */
+ 74, /* i_add */
+ 74, /* subtract */
+ 74, /* i_subtract */
+ 74, /* concat */
+ 79, /* stringify */
+ 74, /* left_shift */
+ 74, /* right_shift */
+ 12, /* lt */
+ 12, /* i_lt */
+ 12, /* gt */
+ 12, /* i_gt */
+ 12, /* le */
+ 12, /* i_le */
+ 12, /* ge */
+ 12, /* i_ge */
+ 12, /* eq */
+ 12, /* i_eq */
+ 12, /* ne */
+ 12, /* i_ne */
+ 12, /* ncmp */
+ 12, /* i_ncmp */
+ 12, /* slt */
+ 12, /* sgt */
+ 12, /* sle */
+ 12, /* sge */
+ 12, /* seq */
+ 12, /* sne */
+ 12, /* scmp */
+ 12, /* bit_and */
+ 12, /* bit_xor */
+ 12, /* bit_or */
+ 0, /* negate */
+ 0, /* i_negate */
+ 0, /* not */
+ 0, /* complement */
+ 12, /* smartmatch */
+ 79, /* atan2 */
+ 72, /* sin */
+ 72, /* cos */
+ 79, /* rand */
+ 79, /* srand */
+ 72, /* exp */
+ 72, /* log */
+ 72, /* sqrt */
+ 72, /* int */
+ 72, /* hex */
+ 72, /* oct */
+ 72, /* abs */
+ 72, /* length */
+ 81, /* substr */
+ 84, /* vec */
+ 79, /* index */
+ 79, /* rindex */
+ 48, /* sprintf */
+ 48, /* formline */
+ 72, /* ord */
+ 72, /* chr */
+ 79, /* crypt */
+ 0, /* ucfirst */
+ 0, /* lcfirst */
+ 0, /* uc */
+ 0, /* lc */
+ 0, /* quotemeta */
+ 87, /* rv2av */
+ 93, /* aelemfast */
+ 93, /* aelemfast_lex */
+ 94, /* aelem */
+ 99, /* aslice */
+ 102, /* kvaslice */
+ 0, /* aeach */
+ 0, /* akeys */
+ 0, /* avalues */
+ 0, /* each */
+ 0, /* values */
+ 39, /* keys */
+ 103, /* delete */
+ 106, /* exists */
+ 108, /* rv2hv */
+ 94, /* helem */
+ 99, /* hslice */
+ 102, /* kvhslice */
+ 48, /* unpack */
+ 48, /* pack */
+ 116, /* split */
+ 48, /* join */
+ 119, /* list */
+ 12, /* lslice */
+ 48, /* anonlist */
+ 48, /* anonhash */
+ 48, /* splice */
+ 79, /* push */
+ 0, /* pop */
+ 0, /* shift */
+ 79, /* unshift */
+ 121, /* sort */
+ 128, /* reverse */
+ 130, /* grepstart */
+ 131, /* grepwhile */
+ 130, /* mapstart */
+ 131, /* mapwhile */
+ 0, /* range */
+ 133, /* flip */
+ 133, /* flop */
+ 0, /* and */
+ 0, /* or */
+ 12, /* xor */
+ 0, /* dor */
+ 135, /* cond_expr */
+ 0, /* andassign */
+ 0, /* orassign */
+ 0, /* dorassign */
+ 0, /* method */
+ 137, /* entersub */
+ 144, /* leavesub */
+ 144, /* leavesublv */
+ 146, /* caller */
+ 48, /* warn */
+ 48, /* die */
+ 48, /* reset */
-1, /* lineseq */
- 332, /* nextstate */
- 335, /* dbstate */
+ 148, /* nextstate */
+ 148, /* dbstate */
-1, /* unstack */
-1, /* enter */
- 338, /* leave */
+ 149, /* leave */
-1, /* scope */
- 340, /* enteriter */
- 344, /* iter */
+ 151, /* enteriter */
+ 155, /* iter */
-1, /* enterloop */
- 345, /* leaveloop */
+ 156, /* leaveloop */
-1, /* return */
- 347, /* last */
- 349, /* next */
- 351, /* redo */
- 353, /* dump */
- 355, /* goto */
- 357, /* exit */
- 358, /* method_named */
- 359, /* entergiven */
- 360, /* leavegiven */
- 361, /* enterwhen */
- 362, /* leavewhen */
+ 158, /* last */
+ 158, /* next */
+ 158, /* redo */
+ 158, /* dump */
+ 158, /* goto */
+ 48, /* exit */
+ 0, /* method_named */
+ 0, /* entergiven */
+ 0, /* leavegiven */
+ 0, /* enterwhen */
+ 0, /* leavewhen */
-1, /* break */
-1, /* continue */
- 363, /* open */
- 368, /* close */
- 369, /* pipe_op */
- 370, /* fileno */
- 371, /* umask */
- 372, /* binmode */
- 373, /* tie */
- 374, /* untie */
- 375, /* tied */
- 376, /* dbmopen */
- 377, /* dbmclose */
- 378, /* sselect */
- 379, /* select */
- 380, /* getc */
- 381, /* read */
- 382, /* enterwrite */
- 383, /* leavewrite */
+ 160, /* open */
+ 48, /* close */
+ 48, /* pipe_op */
+ 48, /* fileno */
+ 48, /* umask */
+ 48, /* binmode */
+ 48, /* tie */
+ 0, /* untie */
+ 0, /* tied */
+ 48, /* dbmopen */
+ 0, /* dbmclose */
+ 48, /* sselect */
+ 48, /* select */
+ 48, /* getc */
+ 48, /* read */
+ 48, /* enterwrite */
+ 144, /* leavewrite */
-1, /* prtf */
-1, /* print */
-1, /* say */
- 385, /* sysopen */
- 386, /* sysseek */
- 387, /* sysread */
- 388, /* syswrite */
- 389, /* eof */
- 390, /* tell */
- 391, /* seek */
- 392, /* truncate */
- 393, /* fcntl */
- 394, /* ioctl */
- 395, /* flock */
- 397, /* send */
- 398, /* recv */
- 399, /* socket */
- 400, /* sockpair */
- 401, /* bind */
- 402, /* connect */
- 403, /* listen */
- 404, /* accept */
- 405, /* shutdown */
- 406, /* gsockopt */
- 407, /* ssockopt */
- 408, /* getsockname */
- 409, /* getpeername */
- 410, /* lstat */
- 411, /* stat */
- 412, /* ftrread */
- 417, /* ftrwrite */
- 422, /* ftrexec */
- 427, /* fteread */
- 432, /* ftewrite */
- 437, /* fteexec */
- 442, /* ftis */
- 446, /* ftsize */
- 450, /* ftmtime */
- 454, /* ftatime */
- 458, /* ftctime */
- 462, /* ftrowned */
- 466, /* fteowned */
- 470, /* ftzero */
- 474, /* ftsock */
- 478, /* ftchr */
- 482, /* ftblk */
- 486, /* ftfile */
- 490, /* ftdir */
- 494, /* ftpipe */
- 498, /* ftsuid */
- 502, /* ftsgid */
- 506, /* ftsvtx */
- 510, /* ftlink */
- 514, /* fttty */
- 518, /* fttext */
- 522, /* ftbinary */
- 526, /* chdir */
- 528, /* chown */
- 530, /* chroot */
- 532, /* unlink */
- 534, /* chmod */
- 536, /* utime */
- 538, /* rename */
- 540, /* link */
- 542, /* symlink */
- 544, /* readlink */
- 545, /* mkdir */
- 547, /* rmdir */
- 549, /* open_dir */
- 550, /* readdir */
- 551, /* telldir */
- 552, /* seekdir */
- 553, /* rewinddir */
- 554, /* closedir */
+ 48, /* sysopen */
+ 48, /* sysseek */
+ 48, /* sysread */
+ 48, /* syswrite */
+ 48, /* eof */
+ 48, /* tell */
+ 48, /* seek */
+ 48, /* truncate */
+ 48, /* fcntl */
+ 48, /* ioctl */
+ 79, /* flock */
+ 48, /* send */
+ 48, /* recv */
+ 48, /* socket */
+ 48, /* sockpair */
+ 48, /* bind */
+ 48, /* connect */
+ 48, /* listen */
+ 48, /* accept */
+ 48, /* shutdown */
+ 48, /* gsockopt */
+ 48, /* ssockopt */
+ 0, /* getsockname */
+ 0, /* getpeername */
+ 0, /* lstat */
+ 0, /* stat */
+ 165, /* ftrread */
+ 165, /* ftrwrite */
+ 165, /* ftrexec */
+ 165, /* fteread */
+ 165, /* ftewrite */
+ 165, /* fteexec */
+ 170, /* ftis */
+ 170, /* ftsize */
+ 170, /* ftmtime */
+ 170, /* ftatime */
+ 170, /* ftctime */
+ 170, /* ftrowned */
+ 170, /* fteowned */
+ 170, /* ftzero */
+ 170, /* ftsock */
+ 170, /* ftchr */
+ 170, /* ftblk */
+ 170, /* ftfile */
+ 170, /* ftdir */
+ 170, /* ftpipe */
+ 170, /* ftsuid */
+ 170, /* ftsgid */
+ 170, /* ftsvtx */
+ 170, /* ftlink */
+ 170, /* fttty */
+ 170, /* fttext */
+ 170, /* ftbinary */
+ 79, /* chdir */
+ 79, /* chown */
+ 72, /* chroot */
+ 79, /* unlink */
+ 79, /* chmod */
+ 79, /* utime */
+ 79, /* rename */
+ 79, /* link */
+ 79, /* symlink */
+ 0, /* readlink */
+ 79, /* mkdir */
+ 72, /* rmdir */
+ 48, /* open_dir */
+ 0, /* readdir */
+ 0, /* telldir */
+ 48, /* seekdir */
+ 0, /* rewinddir */
+ 0, /* closedir */
-1, /* fork */
- 555, /* wait */
- 556, /* waitpid */
- 558, /* system */
- 560, /* exec */
- 562, /* kill */
- 564, /* getppid */
- 565, /* getpgrp */
- 567, /* setpgrp */
- 569, /* getpriority */
- 571, /* setpriority */
- 573, /* time */
+ 174, /* wait */
+ 79, /* waitpid */
+ 79, /* system */
+ 79, /* exec */
+ 79, /* kill */
+ 174, /* getppid */
+ 79, /* getpgrp */
+ 79, /* setpgrp */
+ 79, /* getpriority */
+ 79, /* setpriority */
+ 174, /* time */
-1, /* tms */
- 574, /* localtime */
- 575, /* gmtime */
- 576, /* alarm */
- 577, /* sleep */
- 579, /* shmget */
- 580, /* shmctl */
- 581, /* shmread */
- 582, /* shmwrite */
- 583, /* msgget */
- 584, /* msgctl */
- 585, /* msgsnd */
- 586, /* msgrcv */
- 587, /* semop */
- 588, /* semget */
- 589, /* semctl */
- 590, /* require */
- 591, /* dofile */
+ 0, /* localtime */
+ 48, /* gmtime */
+ 0, /* alarm */
+ 79, /* sleep */
+ 48, /* shmget */
+ 48, /* shmctl */
+ 48, /* shmread */
+ 48, /* shmwrite */
+ 48, /* msgget */
+ 48, /* msgctl */
+ 48, /* msgsnd */
+ 48, /* msgrcv */
+ 48, /* semop */
+ 48, /* semget */
+ 48, /* semctl */
+ 0, /* require */
+ 0, /* dofile */
-1, /* hintseval */
- 592, /* entereval */
- 598, /* leaveeval */
- 600, /* entertry */
+ 175, /* entereval */
+ 144, /* leaveeval */
+ 0, /* entertry */
-1, /* leavetry */
- 601, /* ghbyname */
- 602, /* ghbyaddr */
+ 0, /* ghbyname */
+ 48, /* ghbyaddr */
-1, /* ghostent */
- 603, /* gnbyname */
- 604, /* gnbyaddr */
+ 0, /* gnbyname */
+ 48, /* gnbyaddr */
-1, /* gnetent */
- 605, /* gpbyname */
- 606, /* gpbynumber */
+ 0, /* gpbyname */
+ 48, /* gpbynumber */
-1, /* gprotoent */
- 607, /* gsbyname */
- 608, /* gsbyport */
+ 48, /* gsbyname */
+ 48, /* gsbyport */
-1, /* gservent */
- 609, /* shostent */
- 610, /* snetent */
- 611, /* sprotoent */
- 612, /* sservent */
+ 0, /* shostent */
+ 0, /* snetent */
+ 0, /* sprotoent */
+ 0, /* sservent */
-1, /* ehostent */
-1, /* enetent */
-1, /* eprotoent */
-1, /* eservent */
- 613, /* gpwnam */
- 614, /* gpwuid */
+ 0, /* gpwnam */
+ 0, /* gpwuid */
-1, /* gpwent */
-1, /* spwent */
-1, /* epwent */
- 615, /* ggrnam */
- 616, /* ggrgid */
+ 0, /* ggrnam */
+ 0, /* ggrgid */
-1, /* ggrent */
-1, /* sgrent */
-1, /* egrent */
-1, /* getlogin */
- 617, /* syscall */
- 618, /* lock */
- 619, /* once */
+ 48, /* syscall */
+ 0, /* lock */
+ 0, /* once */
-1, /* custom */
- 620, /* reach */
- 621, /* rkeys */
- 623, /* rvalues */
- 624, /* coreargs */
- 628, /* runcv */
- 629, /* fc */
+ 0, /* reach */
+ 39, /* rkeys */
+ 0, /* rvalues */
+ 181, /* coreargs */
+ 3, /* runcv */
+ 0, /* fc */
-1, /* padcv */
-1, /* introcv */
-1, /* clonecv */
- 630, /* padrange */
- 632, /* refassign */
- 638, /* lvref */
- 644, /* lvrefslice */
- 645, /* lvavref */
+ 185, /* padrange */
+ 187, /* refassign */
+ 193, /* lvref */
+ 199, /* lvrefslice */
+ 200, /* lvavref */
};
*/
EXTCONST U16 PL_op_private_bitdefs[] = {
- /* scalar */ 0x0003,
- /* pushmark */ 0x281c, 0x3a11,
- /* wantarray */ 0x00bd,
- /* const */ 0x03b8, 0x1490, 0x3acc, 0x3588, 0x2be5,
- /* gvsv */ 0x281c, 0x2d31,
- /* gv */ 0x12f5,
- /* gelem */ 0x0067,
- /* padsv */ 0x281c, 0x025a, 0x3a11,
- /* padav */ 0x281c, 0x3a10, 0x290c, 0x3709,
- /* padhv */ 0x281c, 0x05d8, 0x0534, 0x3a10, 0x290c, 0x3709,
- /* pushre */ 0x34d9,
- /* rv2gv */ 0x281c, 0x025a, 0x1590, 0x290c, 0x2b08, 0x3ac4, 0x0003,
- /* rv2sv */ 0x281c, 0x025a, 0x2d30, 0x3ac4, 0x0003,
- /* av2arylen */ 0x290c, 0x0003,
- /* rv2cv */ 0x2a7c, 0x08f8, 0x0b90, 0x028c, 0x3c88, 0x3ac4, 0x0003,
- /* prototype */ 0x0003,
- /* refgen */ 0x0003,
- /* srefgen */ 0x0003,
- /* ref */ 0x0003,
- /* bless */ 0x012f,
- /* backtick */ 0x2f1c, 0x2e38, 0x22f4, 0x2230, 0x0003,
- /* glob */ 0x012f,
- /* readline */ 0x0003,
- /* regcmaybe */ 0x0003,
- /* regcreset */ 0x0003,
- /* regcomp */ 0x0003,
- /* match */ 0x34d8, 0x3d31,
- /* qr */ 0x34d9,
- /* subst */ 0x34d8, 0x3d31,
- /* substcont */ 0x34d8, 0x0003,
- /* trans */ 0x0c9c, 0x1c18, 0x0834, 0x3d30, 0x384c, 0x1fa8, 0x01e4, 0x0141,
- /* transr */ 0x0c9c, 0x1c18, 0x0834, 0x3d30, 0x384c, 0x1fa8, 0x01e4, 0x0141,
- /* sassign */ 0x0adc, 0x0458, 0x0067,
- /* aassign */ 0x0758, 0x290c, 0x0067,
- /* chop */ 0x0003,
- /* schop */ 0x0003,
- /* chomp */ 0x3d30, 0x0003,
- /* schomp */ 0x3d30, 0x0003,
- /* defined */ 0x0003,
- /* undef */ 0x0003,
- /* study */ 0x0003,
- /* pos */ 0x290c, 0x0003,
- /* preinc */ 0x0003,
- /* i_preinc */ 0x0003,
- /* predec */ 0x0003,
- /* i_predec */ 0x0003,
- /* postinc */ 0x0003,
- /* i_postinc */ 0x3d30, 0x0003,
- /* postdec */ 0x0003,
- /* i_postdec */ 0x3d30, 0x0003,
- /* pow */ 0x3d30, 0x0067,
- /* multiply */ 0x3d30, 0x0067,
- /* i_multiply */ 0x3d30, 0x0067,
- /* divide */ 0x3d30, 0x0067,
- /* i_divide */ 0x3d30, 0x0067,
- /* modulo */ 0x3d30, 0x0067,
- /* i_modulo */ 0x3d30, 0x0067,
- /* repeat */ 0x0f78, 0x0067,
- /* add */ 0x3d30, 0x0067,
- /* i_add */ 0x3d30, 0x0067,
- /* subtract */ 0x3d30, 0x0067,
- /* i_subtract */ 0x3d30, 0x0067,
- /* concat */ 0x3d30, 0x0067,
- /* stringify */ 0x3d30, 0x012f,
- /* left_shift */ 0x3d30, 0x0067,
- /* right_shift */ 0x3d30, 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 */ 0x3d30, 0x0003,
- /* not */ 0x0003,
- /* complement */ 0x0003,
- /* smartmatch */ 0x0067,
- /* atan2 */ 0x3d30, 0x012f,
- /* sin */ 0x3d30, 0x0003,
- /* cos */ 0x3d30, 0x0003,
- /* rand */ 0x3d30, 0x012f,
- /* srand */ 0x3d30, 0x012f,
- /* exp */ 0x3d30, 0x0003,
- /* log */ 0x3d30, 0x0003,
- /* sqrt */ 0x3d30, 0x0003,
- /* int */ 0x3d30, 0x0003,
- /* hex */ 0x3d30, 0x0003,
- /* oct */ 0x3d30, 0x0003,
- /* abs */ 0x3d30, 0x0003,
- /* length */ 0x3d30, 0x0003,
- /* substr */ 0x3230, 0x290c, 0x00cb,
- /* vec */ 0x290c, 0x0067,
- /* index */ 0x3d30, 0x012f,
- /* rindex */ 0x3d30, 0x012f,
- /* sprintf */ 0x012f,
- /* formline */ 0x012f,
- /* ord */ 0x3d30, 0x0003,
- /* chr */ 0x3d30, 0x0003,
- /* crypt */ 0x3d30, 0x012f,
- /* ucfirst */ 0x0003,
- /* lcfirst */ 0x0003,
- /* uc */ 0x0003,
- /* lc */ 0x0003,
- /* quotemeta */ 0x0003,
- /* rv2av */ 0x281c, 0x2d30, 0x290c, 0x3708, 0x3ac4, 0x0003,
- /* aelemfast */ 0x01ff,
- /* aelemfast_lex */ 0x01ff,
- /* aelem */ 0x281c, 0x025a, 0x2710, 0x290c, 0x0067,
- /* aslice */ 0x281c, 0x290c, 0x3709,
- /* kvaslice */ 0x290d,
- /* aeach */ 0x0003,
- /* akeys */ 0x0003,
- /* avalues */ 0x0003,
- /* each */ 0x0003,
- /* values */ 0x0003,
- /* keys */ 0x290c, 0x0003,
- /* delete */ 0x281c, 0x3658, 0x0003,
- /* exists */ 0x3bb8, 0x0003,
- /* rv2hv */ 0x281c, 0x05d8, 0x0534, 0x2d30, 0x290c, 0x3708, 0x3ac4, 0x0003,
- /* helem */ 0x281c, 0x025a, 0x2710, 0x290c, 0x0067,
- /* hslice */ 0x281c, 0x290c, 0x3709,
- /* kvhslice */ 0x290d,
- /* unpack */ 0x012f,
- /* pack */ 0x012f,
- /* split */ 0x207c, 0x2d31,
- /* join */ 0x012f,
- /* list */ 0x281c, 0x1cd9,
- /* lslice */ 0x0067,
- /* anonlist */ 0x012f,
- /* anonhash */ 0x012f,
- /* splice */ 0x012f,
- /* push */ 0x3d30, 0x012f,
- /* pop */ 0x0003,
- /* shift */ 0x0003,
- /* unshift */ 0x3d30, 0x012f,
- /* sort */ 0x3938, 0x2fd4, 0x0ed0, 0x238c, 0x3328, 0x2484, 0x2ca1,
- /* reverse */ 0x238c, 0x0003,
- /* grepstart */ 0x1b05,
- /* grepwhile */ 0x1b04, 0x0003,
- /* mapstart */ 0x1b05,
- /* mapwhile */ 0x1b04, 0x0003,
- /* range */ 0x0003,
- /* flip */ 0x25b8, 0x0003,
- /* flop */ 0x25b8, 0x0003,
- /* and */ 0x0003,
- /* or */ 0x0003,
- /* xor */ 0x0067,
- /* dor */ 0x0003,
- /* cond_expr */ 0x281c, 0x0003,
- /* andassign */ 0x0003,
- /* orassign */ 0x0003,
- /* dorassign */ 0x0003,
- /* method */ 0x0003,
- /* entersub */ 0x281c, 0x025a, 0x0b90, 0x028c, 0x3c88, 0x3ac4, 0x2141,
- /* leavesub */ 0x3098, 0x0003,
- /* leavesublv */ 0x3098, 0x0003,
- /* caller */ 0x00bc, 0x012f,
- /* warn */ 0x012f,
- /* die */ 0x012f,
- /* reset */ 0x012f,
- /* nextstate */ 0x40dc, 0x3f18, 0x1eb5,
- /* dbstate */ 0x40dc, 0x3f18, 0x1eb5,
- /* leave */ 0x26bc, 0x3099,
- /* enteriter */ 0x281c, 0x2d30, 0x0c0c, 0x33a9,
- /* iter */ 0x33a9,
- /* leaveloop */ 0x26bc, 0x0067,
- /* last */ 0x3e9c, 0x0003,
- /* next */ 0x3e9c, 0x0003,
- /* redo */ 0x3e9c, 0x0003,
- /* dump */ 0x3e9c, 0x0003,
- /* goto */ 0x3e9c, 0x0003,
- /* exit */ 0x012f,
- /* method_named */ 0x0003,
- /* entergiven */ 0x0003,
- /* leavegiven */ 0x0003,
- /* enterwhen */ 0x0003,
- /* leavewhen */ 0x0003,
- /* open */ 0x2f1c, 0x2e38, 0x22f4, 0x2230, 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 */ 0x3098, 0x0003,
- /* sysopen */ 0x012f,
- /* sysseek */ 0x012f,
- /* sysread */ 0x012f,
- /* syswrite */ 0x012f,
- /* eof */ 0x012f,
- /* tell */ 0x012f,
- /* seek */ 0x012f,
- /* truncate */ 0x012f,
- /* fcntl */ 0x012f,
- /* ioctl */ 0x012f,
- /* flock */ 0x3d30, 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 */ 0x1750, 0x19ac, 0x1868, 0x1624, 0x0003,
- /* ftrwrite */ 0x1750, 0x19ac, 0x1868, 0x1624, 0x0003,
- /* ftrexec */ 0x1750, 0x19ac, 0x1868, 0x1624, 0x0003,
- /* fteread */ 0x1750, 0x19ac, 0x1868, 0x1624, 0x0003,
- /* ftewrite */ 0x1750, 0x19ac, 0x1868, 0x1624, 0x0003,
- /* fteexec */ 0x1750, 0x19ac, 0x1868, 0x1624, 0x0003,
- /* ftis */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftsize */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftmtime */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftatime */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftctime */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftrowned */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* fteowned */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftzero */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftsock */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftchr */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftblk */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftfile */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftdir */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftpipe */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftsuid */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftsgid */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftsvtx */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftlink */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* fttty */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* fttext */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* ftbinary */ 0x1750, 0x19ac, 0x1868, 0x0003,
- /* chdir */ 0x3d30, 0x012f,
- /* chown */ 0x3d30, 0x012f,
- /* chroot */ 0x3d30, 0x0003,
- /* unlink */ 0x3d30, 0x012f,
- /* chmod */ 0x3d30, 0x012f,
- /* utime */ 0x3d30, 0x012f,
- /* rename */ 0x3d30, 0x012f,
- /* link */ 0x3d30, 0x012f,
- /* symlink */ 0x3d30, 0x012f,
- /* readlink */ 0x0003,
- /* mkdir */ 0x3d30, 0x012f,
- /* rmdir */ 0x3d30, 0x0003,
- /* open_dir */ 0x012f,
- /* readdir */ 0x0003,
- /* telldir */ 0x0003,
- /* seekdir */ 0x012f,
- /* rewinddir */ 0x0003,
- /* closedir */ 0x0003,
- /* wait */ 0x3d31,
- /* waitpid */ 0x3d30, 0x012f,
- /* system */ 0x3d30, 0x012f,
- /* exec */ 0x3d30, 0x012f,
- /* kill */ 0x3d30, 0x012f,
- /* getppid */ 0x3d31,
- /* getpgrp */ 0x3d30, 0x012f,
- /* setpgrp */ 0x3d30, 0x012f,
- /* getpriority */ 0x3d30, 0x012f,
- /* setpriority */ 0x3d30, 0x012f,
- /* time */ 0x3d31,
- /* localtime */ 0x0003,
- /* gmtime */ 0x012f,
- /* alarm */ 0x0003,
- /* sleep */ 0x3d30, 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 */ 0x3134, 0x09b0, 0x068c, 0x3e08, 0x1dc4, 0x0003,
- /* leaveeval */ 0x3098, 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 */ 0x290c, 0x0003,
- /* rvalues */ 0x0003,
- /* coreargs */ 0x29dc, 0x0018, 0x0de4, 0x0d01,
- /* runcv */ 0x00bd,
- /* fc */ 0x0003,
- /* padrange */ 0x281c, 0x019b,
- /* refassign */ 0x281c, 0x037a, 0x3a10, 0x250c, 0x13e8, 0x0067,
- /* lvref */ 0x281c, 0x037a, 0x3a10, 0x250c, 0x13e8, 0x0003,
- /* lvrefslice */ 0x281d,
- /* lvavref */ 0x281c, 0x3a10, 0x0003,
+ 0x0003, /* scalar, prototype, refgen, srefgen, ref, readline, regcmaybe, regcreset, regcomp, chop, schop, defined, undef, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, complement, ucfirst, lcfirst, uc, lc, quotemeta, aeach, akeys, avalues, each, values, pop, shift, range, and, or, dor, andassign, orassign, dorassign, method, method_named, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, reach, rvalues, fc */
+ 0x281c, 0x3a19, /* pushmark */
+ 0x00bd, /* wantarray, runcv */
+ 0x03b8, 0x1490, 0x3acc, 0x3588, 0x2be5, /* const */
+ 0x281c, 0x2d39, /* gvsv */
+ 0x12f5, /* gv */
+ 0x0067, /* gelem, lt, i_lt, gt, i_gt, le, i_le, ge, i_ge, eq, i_eq, ne, i_ne, ncmp, i_ncmp, slt, sgt, sle, sge, seq, sne, scmp, bit_and, bit_xor, bit_or, smartmatch, lslice, xor */
+ 0x281c, 0x3a18, 0x0257, /* padsv */
+ 0x281c, 0x3a18, 0x290c, 0x3709, /* padav */
+ 0x281c, 0x3a18, 0x0534, 0x05d0, 0x290c, 0x3709, /* padhv */
+ 0x34d9, /* pushre, qr */
+ 0x281c, 0x1598, 0x0256, 0x290c, 0x2b08, 0x3ac4, 0x0003, /* rv2gv */
+ 0x281c, 0x2d38, 0x0256, 0x3ac4, 0x0003, /* rv2sv */
+ 0x290c, 0x0003, /* av2arylen, pos, keys, rkeys */
+ 0x2a7c, 0x0b98, 0x08f4, 0x028c, 0x3c88, 0x3ac4, 0x0003, /* rv2cv */
+ 0x012f, /* bless, glob, sprintf, formline, unpack, pack, join, anonlist, anonhash, splice, warn, die, reset, exit, close, pipe_op, fileno, umask, binmode, tie, dbmopen, sselect, select, getc, read, enterwrite, sysopen, sysseek, sysread, syswrite, eof, tell, seek, truncate, fcntl, ioctl, send, recv, socket, sockpair, bind, connect, listen, accept, shutdown, gsockopt, ssockopt, open_dir, seekdir, gmtime, shmget, shmctl, shmread, shmwrite, msgget, msgctl, msgsnd, msgrcv, semop, semget, semctl, ghbyaddr, gnbyaddr, gpbynumber, gsbyname, gsbyport, syscall */
+ 0x2f1c, 0x2e38, 0x22f4, 0x2230, 0x0003, /* backtick */
+ 0x34d8, 0x3d31, /* match, subst */
+ 0x34d8, 0x0003, /* substcont */
+ 0x0c9c, 0x1c18, 0x0834, 0x3d30, 0x384c, 0x1fa8, 0x01e4, 0x0141, /* trans, transr */
+ 0x0adc, 0x0458, 0x0067, /* sassign */
+ 0x0758, 0x290c, 0x0067, /* aassign */
+ 0x3d30, 0x0003, /* chomp, schomp, sin, cos, exp, log, sqrt, int, hex, oct, abs, length, ord, chr, chroot, rmdir */
+ 0x3d30, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract, concat, left_shift, right_shift */
+ 0x0f78, 0x3d30, 0x0067, /* repeat */
+ 0x3d30, 0x012f, /* stringify, atan2, rand, srand, index, rindex, crypt, push, unshift, flock, chdir, chown, unlink, chmod, utime, rename, link, symlink, mkdir, waitpid, system, exec, kill, getpgrp, setpgrp, getpriority, setpriority, sleep */
+ 0x3230, 0x290c, 0x00cb, /* substr */
+ 0x3d30, 0x290c, 0x0067, /* vec */
+ 0x281c, 0x2d38, 0x290c, 0x3708, 0x3ac4, 0x0003, /* rv2av */
+ 0x01ff, /* aelemfast, aelemfast_lex */
+ 0x281c, 0x2718, 0x0256, 0x290c, 0x0067, /* aelem, helem */
+ 0x281c, 0x290c, 0x3709, /* aslice, hslice */
+ 0x290d, /* kvaslice, kvhslice */
+ 0x281c, 0x3658, 0x0003, /* delete */
+ 0x3bb8, 0x0003, /* exists */
+ 0x281c, 0x2d38, 0x0534, 0x05d0, 0x290c, 0x3708, 0x3ac4, 0x0003, /* rv2hv */
+ 0x207c, 0x2d38, 0x3d31, /* split */
+ 0x281c, 0x1cd9, /* list */
+ 0x3938, 0x2fd4, 0x0ed0, 0x238c, 0x3328, 0x2484, 0x2ca1, /* sort */
+ 0x238c, 0x0003, /* reverse */
+ 0x1b05, /* grepstart, mapstart */
+ 0x1b04, 0x0003, /* grepwhile, mapwhile */
+ 0x25b8, 0x0003, /* flip, flop */
+ 0x281c, 0x0003, /* cond_expr */
+ 0x281c, 0x0b98, 0x0256, 0x028c, 0x3c88, 0x3ac4, 0x2141, /* entersub */
+ 0x3098, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */
+ 0x00bc, 0x012f, /* caller */
+ 0x1eb5, /* nextstate, dbstate */
+ 0x26bc, 0x3099, /* leave */
+ 0x281c, 0x2d38, 0x0c0c, 0x33a9, /* enteriter */
+ 0x33a9, /* iter */
+ 0x26bc, 0x0067, /* leaveloop */
+ 0x3e9c, 0x0003, /* last, next, redo, dump, goto */
+ 0x2f1c, 0x2e38, 0x22f4, 0x2230, 0x012f, /* open */
+ 0x1750, 0x19ac, 0x1868, 0x1624, 0x0003, /* ftrread, ftrwrite, ftrexec, fteread, ftewrite, fteexec */
+ 0x1750, 0x19ac, 0x1868, 0x0003, /* ftis, ftsize, ftmtime, ftatime, ftctime, ftrowned, fteowned, ftzero, ftsock, ftchr, ftblk, ftfile, ftdir, ftpipe, ftsuid, ftsgid, ftsvtx, ftlink, fttty, fttext, ftbinary */
+ 0x3d31, /* wait, getppid, time */
+ 0x3134, 0x09b0, 0x068c, 0x3e08, 0x1dc4, 0x0003, /* entereval */
+ 0x29dc, 0x0018, 0x0de4, 0x0d01, /* coreargs */
+ 0x281c, 0x019b, /* padrange */
+ 0x281c, 0x3a18, 0x0376, 0x250c, 0x13e8, 0x0067, /* refassign */
+ 0x281c, 0x3a18, 0x0376, 0x250c, 0x13e8, 0x0003, /* lvref */
+ 0x281d, /* lvrefslice */
+ 0x281c, 0x3a18, 0x0003, /* lvavref */
};
/* GVSV */ (OPpOUR_INTRO|OPpLVAL_INTRO),
/* GV */ (OPpEARLY_CV),
/* GELEM */ (OPpARG2_MASK),
- /* PADSV */ (OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO),
+ /* PADSV */ (OPpDEREF|OPpPAD_STATE|OPpLVAL_INTRO),
/* PADAV */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpPAD_STATE|OPpLVAL_INTRO),
- /* PADHV */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpPAD_STATE|OPpTRUEBOOL|OPpMAYBE_TRUEBOOL|OPpLVAL_INTRO),
+ /* PADHV */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpMAYBE_TRUEBOOL|OPpTRUEBOOL|OPpPAD_STATE|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),
+ /* RV2GV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpDONT_INIT_GV|OPpMAYBE_LVSUB|OPpDEREF|OPpALLOW_FAKE|OPpLVAL_INTRO),
+ /* RV2SV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpDEREF|OPpOUR_INTRO|OPpLVAL_INTRO),
/* AV2ARYLEN */ (OPpARG1_MASK|OPpMAYBE_LVSUB),
- /* RV2CV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpENTERSUB_HASTARG|OPpENTERSUB_AMPER|OPpENTERSUB_DB|OPpMAY_RETURN_CONSTANT|OPpENTERSUB_NOPAREN),
+ /* RV2CV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpENTERSUB_HASTARG|OPpENTERSUB_AMPER|OPpMAY_RETURN_CONSTANT|OPpENTERSUB_DB|OPpENTERSUB_NOPAREN),
/* ANONCODE */ (0),
/* PROTOTYPE */ (OPpARG1_MASK),
/* REFGEN */ (OPpARG1_MASK),
/* PREDEC */ (OPpARG1_MASK),
/* I_PREDEC */ (OPpARG1_MASK),
/* POSTINC */ (OPpARG1_MASK),
- /* I_POSTINC */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* I_POSTINC */ (OPpARG1_MASK),
/* POSTDEC */ (OPpARG1_MASK),
- /* I_POSTDEC */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* I_POSTDEC */ (OPpARG1_MASK),
/* POW */ (OPpARG2_MASK|OPpTARGET_MY),
/* MULTIPLY */ (OPpARG2_MASK|OPpTARGET_MY),
/* I_MULTIPLY */ (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),
+ /* REPEAT */ (OPpARG2_MASK|OPpTARGET_MY|OPpREPEAT_DOLIST),
/* ADD */ (OPpARG2_MASK|OPpTARGET_MY),
/* I_ADD */ (OPpARG2_MASK|OPpTARGET_MY),
/* SUBTRACT */ (OPpARG2_MASK|OPpTARGET_MY),
/* BIT_XOR */ (OPpARG2_MASK),
/* BIT_OR */ (OPpARG2_MASK),
/* NEGATE */ (OPpARG1_MASK),
- /* I_NEGATE */ (OPpARG1_MASK|OPpTARGET_MY),
+ /* I_NEGATE */ (OPpARG1_MASK),
/* NOT */ (OPpARG1_MASK),
/* COMPLEMENT */ (OPpARG1_MASK),
/* SMARTMATCH */ (OPpARG2_MASK),
/* ABS */ (OPpARG1_MASK|OPpTARGET_MY),
/* LENGTH */ (OPpARG1_MASK|OPpTARGET_MY),
/* SUBSTR */ (OPpARG3_MASK|OPpMAYBE_LVSUB|OPpSUBSTR_REPL_FIRST),
- /* VEC */ (OPpARG2_MASK|OPpMAYBE_LVSUB),
+ /* VEC */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpTARGET_MY),
/* INDEX */ (OPpARG4_MASK|OPpTARGET_MY),
/* RINDEX */ (OPpARG4_MASK|OPpTARGET_MY),
/* SPRINTF */ (OPpARG4_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),
+ /* AELEM */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpDEREF|OPpLVAL_DEFER|OPpLVAL_INTRO),
/* ASLICE */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpLVAL_INTRO),
/* KVASLICE */ (OPpMAYBE_LVSUB),
/* AEACH */ (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),
+ /* RV2HV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpMAYBE_TRUEBOOL|OPpTRUEBOOL|OPpOUR_INTRO|OPpLVAL_INTRO),
+ /* HELEM */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpDEREF|OPpLVAL_DEFER|OPpLVAL_INTRO),
/* HSLICE */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpLVAL_INTRO),
/* KVHSLICE */ (OPpMAYBE_LVSUB),
/* UNPACK */ (OPpARG4_MASK),
/* PACK */ (OPpARG4_MASK),
- /* SPLIT */ (OPpOUR_INTRO|OPpSPLIT_IMPLIM),
+ /* SPLIT */ (OPpTARGET_MY|OPpOUR_INTRO|OPpSPLIT_IMPLIM),
/* JOIN */ (OPpARG4_MASK),
/* LIST */ (OPpLIST_GUESSED|OPpLVAL_INTRO),
/* LSLICE */ (OPpARG2_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),
+ /* ENTERSUB */ (OPpENTERSUB_INARGS|OPpHINT_STRICT_REFS|OPpENTERSUB_HASTARG|OPpENTERSUB_AMPER|OPpDEREF|OPpENTERSUB_DB|OPpLVAL_INTRO),
/* LEAVESUB */ (OPpARG1_MASK|OPpREFCOUNTED),
/* LEAVESUBLV */ (OPpARG1_MASK|OPpREFCOUNTED),
/* CALLER */ (OPpARG4_MASK|OPpOFFBYONE),
/* 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),
+ /* NEXTSTATE */ (OPpHUSH_VMSISH),
+ /* DBSTATE */ (OPpHUSH_VMSISH),
/* UNSTACK */ (0),
/* ENTER */ (0),
/* LEAVE */ (OPpREFCOUNTED|OPpLVALUE),
/* INTROCV */ (0),
/* CLONECV */ (0),
/* PADRANGE */ (OPpPADRANGE_COUNTMASK|OPpLVAL_INTRO),
- /* REFASSIGN */ (OPpARG2_MASK|OPpLVREF_ELEM|OPpLVREF_ITER|OPpPAD_STATE|OPpLVREF_TYPE|OPpLVAL_INTRO),
- /* LVREF */ (OPpARG1_MASK|OPpLVREF_ELEM|OPpLVREF_ITER|OPpPAD_STATE|OPpLVREF_TYPE|OPpLVAL_INTRO),
+ /* REFASSIGN */ (OPpARG2_MASK|OPpLVREF_ELEM|OPpLVREF_ITER|OPpLVREF_TYPE|OPpPAD_STATE|OPpLVAL_INTRO),
+ /* LVREF */ (OPpARG1_MASK|OPpLVREF_ELEM|OPpLVREF_ITER|OPpLVREF_TYPE|OPpPAD_STATE|OPpLVAL_INTRO),
/* LVREFSLICE */ (OPpLVAL_INTRO),
/* LVAVREF */ (OPpARG1_MASK|OPpPAD_STATE|OPpLVAL_INTRO),
executing). Require'd files are simply evals without any outer lexical
scope.
-XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
+XSUBs do not have a CvPADLIST. dXSTARG fetches values from PL_curpad,
but that is really the callers pad (a slot of which is allocated by
-every entersub).
+every entersub). Do not get or set CvPADLIST if a CV is an XSUB (as
+determined by C<CvISXSUB()>), CvPADLIST slot is reused for a different
+internal purpose in XSUBs.
The PADLIST has a C array where pads are stored.
|| memEQ(SvPVX_const(sv), pv, pvlen));
}
+#ifdef DEBUGGING
+void
+Perl_set_padlist(pTHX_ CV * cv, PADLIST *padlist){
+ PERL_ARGS_ASSERT_SET_PADLIST;
+# if PTRSIZE == 8
+ if((Size_t)padlist == UINT64_C(0xEFEFEFEFEFEFEFEF)){
+ assert(0);
+ }
+# elif PTRSIZE == 4
+ if((Size_t)padlist == UINT64_C(0xEFEFEFEF)){
+ assert(0);
+ }
+# else
+# error unknown pointer size
+# endif
+ if(CvISXSUB(cv)){
+ assert(0);
+ }
+ ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist;
+}
+#endif
/*
=for apidoc Am|PADLIST *|pad_new|int flags
void
Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
{
- const PADLIST *padlist = CvPADLIST(cv);
- bool const slabbed = !!CvSLABBED(cv);
+ CV cvbody;/*CV body will never be realloced inside this func,
+ so dont read it more than once, use fake CV so existing macros
+ will work, the indirection and CV head struct optimized away*/
+ SvANY(&cvbody) = SvANY(cv);
PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
PTR2UV(cv), PTR2UV(PL_comppad))
);
- if (CvFILE(cv) && CvDYNFILE(cv)) {
- Safefree(CvFILE(cv));
+ if (CvFILE(&cvbody)) {
+ char * file = CvFILE(&cvbody);
+ CvFILE(&cvbody) = NULL;
+ if(CvDYNFILE(&cvbody))
+ Safefree(file);
}
- CvFILE(cv) = NULL;
- CvSLABBED_off(cv);
- if (!CvISXSUB(cv) && CvROOT(cv)) {
- if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
- Perl_croak(aTHX_ "Can't undef active subroutine");
- ENTER;
-
- PAD_SAVE_SETNULLPAD();
-
- if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
- op_free(CvROOT(cv));
- CvROOT(cv) = NULL;
- CvSTART(cv) = NULL;
- LEAVE;
- }
- else if (slabbed && CvSTART(cv)) {
- ENTER;
- PAD_SAVE_SETNULLPAD();
-
- /* discard any leaked ops */
- if (PL_parser)
- parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv));
- opslab_force_free((OPSLAB *)CvSTART(cv));
- CvSTART(cv) = NULL;
-
- LEAVE;
- }
+ /* CvSLABBED_off(&cvbody); *//* turned off below */
+ /* release the sub's body */
+ if (!CvISXSUB(&cvbody)) {
+ if(CvROOT(&cvbody)) {
+ assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
+ if (CvDEPTHunsafe(&cvbody)) {
+ assert(SvTYPE(cv) == SVt_PVCV);
+ Perl_croak_nocontext("Can't undef active subroutine");
+ }
+ ENTER;
+
+ PAD_SAVE_SETNULLPAD();
+
+ if (CvSLABBED(&cvbody)) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(&cvbody)));
+ op_free(CvROOT(&cvbody));
+ CvROOT(&cvbody) = NULL;
+ CvSTART(&cvbody) = NULL;
+ LEAVE;
+ }
+ else if (CvSLABBED(&cvbody)) {
+ if( CvSTART(&cvbody)) {
+ ENTER;
+ PAD_SAVE_SETNULLPAD();
+
+ /* discard any leaked ops */
+ if (PL_parser)
+ parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(&cvbody));
+ opslab_force_free((OPSLAB *)CvSTART(&cvbody));
+ CvSTART(&cvbody) = NULL;
+
+ LEAVE;
+ }
#ifdef DEBUGGING
- else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
+ else Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
#endif
+ }
+ }
+ else { /* dont bother checking if CvXSUB(cv) is true, less branching */
+ CvXSUB(&cvbody) = NULL;
+ }
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
if (!(flags & CV_UNDEF_KEEP_NAME)) {
- if (CvNAMED(cv)) {
- CvNAME_HEK_set(cv, NULL);
- CvNAMED_off(cv);
+ if (CvNAMED(&cvbody)) {
+ CvNAME_HEK_set(&cvbody, NULL);
+ CvNAMED_off(&cvbody);
}
else CvGV_set(cv, NULL);
}
/* This statement and the subsequence if block was pad_undef(). */
pad_peg("pad_undef");
- if (padlist) {
+ if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
I32 ix;
+ const PADLIST *padlist = CvPADLIST(&cvbody);
/* Free the padlist associated with a CV.
If parts of it happen to be current, we null the relevant PL_*pad*
* children, or integrate this loop with general cleanup */
if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
- CV * const outercv = CvOUTSIDE(cv);
- const U32 seq = CvOUTSIDE_SEQ(cv);
+ CV * const outercv = CvOUTSIDE(&cvbody);
+ const U32 seq = CvOUTSIDE_SEQ(&cvbody);
PAD * const comppad_name = PadlistARRAY(padlist)[0];
SV ** const namepad = AvARRAY(comppad_name);
PAD * const comppad = PadlistARRAY(padlist)[1];
}
if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
Safefree(padlist);
- CvPADLIST(cv) = NULL;
+ CvPADLIST_set(&cvbody, NULL);
}
+ else if (CvISXSUB(&cvbody))
+ CvHSCXT(&cvbody) = NULL;
+ /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
/* remove CvOUTSIDE unless this is an undef rather than a free */
- if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
- if (!CvWEAKOUTSIDE(cv))
- SvREFCNT_dec(CvOUTSIDE(cv));
- CvOUTSIDE(cv) = NULL;
- }
- if (CvCONST(cv)) {
- SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
- CvCONST_off(cv);
+ if (!SvREFCNT(cv)) {
+ CV * outside = CvOUTSIDE(&cvbody);
+ if(outside) {
+ CvOUTSIDE(&cvbody) = NULL;
+ if (!CvWEAKOUTSIDE(&cvbody))
+ SvREFCNT_dec_NN(outside);
+ }
}
- if (CvISXSUB(cv) && CvXSUB(cv)) {
- CvXSUB(cv) = NULL;
+ if (CvCONST(&cvbody)) {
+ SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
+ /* CvCONST_off(cv); *//* turned off below */
}
/* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
* 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
+ CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
|CVf_NAMED);
}
fake_offset = offset; /* in case we don't find a real one */
continue;
}
- /* is seq within the range _LOW to _HIGH ?
- * This is complicated by the fact that PL_cop_seqmax
- * may have wrapped around at some point */
- if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
- continue; /* not yet introduced */
-
- if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
- /* in compiling scope */
- if (
- (seq > COP_SEQ_RANGE_LOW(namesv))
- ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
- : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
- )
- break;
- }
- else if (
- (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
- ?
- ( seq > COP_SEQ_RANGE_LOW(namesv)
- || seq <= COP_SEQ_RANGE_HIGH(namesv))
-
- : ( seq > COP_SEQ_RANGE_LOW(namesv)
- && seq <= COP_SEQ_RANGE_HIGH(namesv))
- )
- break;
+ if (PadnameIN_SCOPE(namesv, seq))
+ break;
}
}
}
/*
-=for apidoc m|U32|intro_my
+=for apidoc Am|U32|intro_my
-"Introduce" my variables to visible status. This is called during parsing
-at the end of each statement to make lexical variables visible to
-subsequent statements.
+"Introduce" C<my> variables to visible status. This is called during parsing
+at the end of each statement to make lexical variables visible to subsequent
+statements.
=cut
*/
U32 seq;
ASSERT_CURPAD_ACTIVE("intro_my");
+ if (PL_compiling.cop_seq) {
+ seq = PL_compiling.cop_seq;
+ PL_compiling.cop_seq = 0;
+ }
+ else
+ seq = PL_cop_seqmax;
if (! PL_min_intro_pending)
- return PL_cop_seqmax;
+ return seq;
svp = AvARRAY(PL_comppad_name);
for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
);
}
}
- seq = PL_cop_seqmax;
- PL_cop_seqmax++;
- if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
- PL_cop_seqmax++;
+ COP_SEQMAX_INC;
PL_min_intro_pending = 0;
PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
}
}
}
- PL_cop_seqmax++;
- if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
- PL_cop_seqmax++;
+ COP_SEQMAX_INC;
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
return o;
static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
-static void
+static CV *
S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
{
I32 ix;
SAVESPTR(PL_comppad_name);
PL_comppad_name = protopad_name;
- CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
+ CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
av_fill(PL_comppad, fpad);
if (newcv) SvREFCNT_inc_simple_void_NN(cv);
LEAVE;
+
+ if (CvCONST(cv)) {
+ /* Constant sub () { $x } closing over $x:
+ * The prototype was marked as a candiate for const-ization,
+ * so try to grab the current const value, and if successful,
+ * turn into a const sub:
+ */
+ SV* const_sv;
+ OP *o = CvSTART(cv);
+ assert(newcv);
+ for (; o; o = o->op_next)
+ if (o->op_type == OP_PADSV)
+ break;
+ ASSUME(o->op_type == OP_PADSV);
+ const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
+ /* the candidate should have 1 ref from this pad and 1 ref
+ * from the parent */
+ if (const_sv && SvREFCNT(const_sv) == 2) {
+ const bool was_method = cBOOL(CvMETHOD(cv));
+ bool copied = FALSE;
+ if (outside) {
+ PADNAME * const pn =
+ PadlistNAMESARRAY(CvPADLIST(outside))
+ [PARENT_PAD_INDEX(PadlistNAMESARRAY(
+ CvPADLIST(cv))[o->op_targ])];
+ assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
+ [o->op_targ]));
+ if (PadnameLVALUE(pn)) {
+ /* We have a lexical that is potentially modifiable
+ elsewhere, so making a constant will break clo-
+ sure behaviour. If this is a ‘simple lexical
+ op tree’, i.e., sub(){$x}, emit a deprecation
+ warning, but continue to exhibit the old behav-
+ iour of making it a constant based on the ref-
+ count of the candidate variable.
+
+ A simple lexical op tree looks like this:
+
+ leavesub
+ lineseq
+ nextstate
+ padsv
+ */
+ if (OP_SIBLING(
+ cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
+ ) == o
+ && !OP_SIBLING(o))
+ {
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_DEPRECATED),
+ "Constants from lexical "
+ "variables potentially "
+ "modified elsewhere are "
+ "deprecated");
+ /* We *copy* the lexical variable, and donate the
+ copy to newCONSTSUB. Yes, this is ugly, and
+ should be killed. We need to do this for the
+ time being, however, because turning on SvPADTMP
+ on a lexical will have observable effects
+ elsewhere. */
+ const_sv = newSVsv(const_sv);
+ copied = TRUE;
+ }
+ else
+ goto constoff;
+ }
+ }
+ if (!copied)
+ SvREFCNT_inc_simple_void_NN(const_sv);
+ /* If the lexical is not used elsewhere, it is safe to turn on
+ SvPADTMP, since it is only when it is used in lvalue con-
+ text that the difference is observable. */
+ SvREADONLY_on(const_sv);
+ SvPADTMP_on(const_sv);
+ SvREFCNT_dec_NN(cv);
+ cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
+ if (was_method)
+ CvMETHOD_on(cv);
+ }
+ else {
+ constoff:
+ CvCONST_off(cv);
+ }
+ }
+
+ return cv;
}
static CV *
if (SvMAGIC(proto))
mg_copy((SV *)proto, (SV *)cv, 0, 0);
- if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
+ if (CvPADLIST(proto))
+ cv = S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
DEBUG_Xv(
PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
cv_dump(cv, "To");
);
- if (CvCONST(cv)) {
- /* Constant sub () { $x } closing over $x - see lib/constant.pm:
- * The prototype was marked as a candiate for const-ization,
- * so try to grab the current const value, and if successful,
- * turn into a const sub:
- */
- SV* const const_sv = op_const_sv(CvSTART(cv), cv);
- if (const_sv) {
- SvREFCNT_dec_NN(cv);
- /* For this calling case, op_const_sv returns a *copy*, which we
- donate to newCONSTSUB. Yes, this is ugly, and should be killed.
- Need to fix how lib/constant.pm works to eliminate this. */
- cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
- }
- else {
- CvCONST_off(cv);
- }
- }
-
return cv;
}
else if (sigil == '%')
sv = MUTABLE_SV(newHV());
else
- {
sv = newSV(0);
- /* For flip-flop targets: */
- if (oldpad[ix] && SvPADTMP(oldpad[ix]))
- SvPADTMP_on(sv);
- }
av_store(newpad, ix, sv);
}
}
PERL_ARGS_ASSERT_PADLIST_DUP;
- if (!srcpad)
- return NULL;
-
cloneall = param->flags & CLONEf_COPY_STACKS
|| SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
* flagging that a lexical is being introduced, or has not yet left scope
*/
#define PERL_PADSEQ_INTRO U32_MAX
+#define COP_SEQMAX_INC \
+ (PL_cop_seqmax++, \
+ (void)(PL_cop_seqmax == PERL_PADSEQ_INTRO && PL_cop_seqmax++))
/* B.xs needs these for the benefit of B::Deparse */
#define PadnameOUTER(pn) !!SvFAKE(pn)
#define PadnameIsSTATE(pn) !!SvPAD_STATE(pn)
#define PadnameTYPE(pn) (SvPAD_TYPED(pn) ? SvSTASH(pn) : NULL)
+#define PadnameLVALUE(pn) \
+ ((SvFLAGS(pn) & (SVpad_NAME|SVpad_LVALUE))==(SVpad_NAME|SVpad_LVALUE))
+#define PadnameLVALUE_on(pn) (SvFLAGS(pn) |= SVpad_NAME|SVpad_LVALUE)
#ifdef DEBUGGING
# define PAD_SV(po) pad_sv(po)
#define PERL_REVISION 5 /* age */
#define PERL_VERSION 21 /* epoch */
-#define PERL_SUBVERSION 5 /* generation */
+#define PERL_SUBVERSION 6 /* 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 5
+#define PERL_API_SUBVERSION 6
/*
XXX Note: The selection of non-default Configure options, such
as -Duselonglong may invalidate these settings. Currently, Configure
PL_stashcache = newHV();
PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING);
- PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING);
#ifdef HAS_MMAP
if (!PL_mmap_page_size) {
Safefree(PL_inplace);
PL_inplace = NULL;
SvREFCNT_dec(PL_patchlevel);
- SvREFCNT_dec(PL_apiversion);
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
"free this thread's memory\n");
PL_debug &= ~ DEBUG_m_FLAG;
}
- while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
- safesysfree(PERL_MEMORY_DEBUG_HEADER_SIZE + (char *)(aTHXx->Imemory_debug_header.next));
+ while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){
+ char * next = (char *)(aTHXx->Imemory_debug_header.next);
+ Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next;
+ safesysfree(ptr);
+ }
PL_debug = old_debug;
}
}
PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
CvUNIQUE_on(PL_compcv);
- CvPADLIST(PL_compcv) = pad_new(0);
+ CvPADLIST_set(PL_compcv, pad_new(0));
PL_isarev = newHV();
return 1;
}
+/* removes boilerplate code at the end of each boot_Module xsub */
+void
+Perl_xs_boot_epilog(pTHX_ const U32 ax)
+{
+ if (PL_unitcheckav)
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+ XSRETURN_YES;
+}
+
/*
* Local variables:
* c-indentation-style: bsd
#define FPTR2DPTR(t,p) ((t)PTR2nat(p)) /* function pointer to data pointer */
#ifdef USE_LONG_DOUBLE
-# if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE == DOUBLESIZE
-# define LONG_DOUBLE_EQUALS_DOUBLE
-# endif
-# if !(defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE))
-# undef USE_LONG_DOUBLE /* Ouch! */
+# if LONG_DOUBLESIZE == DOUBLESIZE
+# define LONG_DOUBLE_EQUALS_DOUBLE
+# undef USE_LONG_DOUBLE /* Ouch! */
# endif
#endif
# ifdef I_SUNMATH
# include <sunmath.h>
# endif
-# if defined(USE_QUADMATH) && defined(I_QUADMATH)
-# include <quadmath.h>
-# endif
-# 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)
+# if defined(LDBL_DIG)
# define NV_DIG LDBL_DIG
# ifdef LDBL_MANT_DIG
# define NV_MANT_DIG LDBL_MANT_DIG
# endif
# endif
# endif
-# 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)
+# if defined(HAS_SQRTL)
# define Perl_acos acosl
# define Perl_asin asinl
# define Perl_atan atanl
# ifndef Perl_isfinite
# define Perl_isfinite(x) Perl_isfinitel(x)
# endif
+#elif defined(USE_QUADMATH) && defined(I_QUADMATH)
+# include <quadmath.h>
+# 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")
+# 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))
#else
# define NV_DIG DBL_DIG
# ifdef DBL_MANT_DIG
#define HINT_FEATURE_MASK 0x1c000000 /* 3 bits for feature bundles */
- /* Note: Used for NATIVE_HINTS, currently
- defined by vms/vmsish.h:
+ /* Note: Used for HINT_M_VMSISH_*,
+ currently defined by vms/vmsish.h:
0x40000000
0x80000000
*/
#undef PERLVARI
#undef PERLVARIC
+#if !defined(MULTIPLICITY)
+/* Set up PERLVAR macros for populating structs */
+# define PERLVAR(prefix,var,type) type prefix##var;
+/* 'var' is an array of length 'n' */
+# define PERLVARA(prefix,var,n,type) type prefix##var[n];
+/* initialize 'var' to init' */
+# define PERLVARI(prefix,var,type,init) type prefix##var;
+/* like PERLVARI, but make 'var' a const */
+# define PERLVARIC(prefix,var,type,init) type prefix##var;
+
+/* this is never instantiated, is it just used for sizeof(struct PerlHandShakeInterpreter) */
+struct PerlHandShakeInterpreter {
+# include "intrpvar.h"
+};
+# undef PERLVAR
+# undef PERLVARA
+# undef PERLVARI
+# undef PERLVARIC
+#endif
+
START_EXTERN_C
/* dummy variables that hold pointers to both runops functions, thus forcing
#define PERLDBf_SAVESRC_NOSUBS 0x800 /* Including evals that generate no subroutines */
#define PERLDBf_SAVESRC_INVALID 0x1000 /* Save source that did not compile */
-#define PERLDB_SUB (PL_perldb && (PL_perldb & PERLDBf_SUB))
-#define PERLDB_LINE (PL_perldb && (PL_perldb & PERLDBf_LINE))
-#define PERLDB_NOOPT (PL_perldb && (PL_perldb & PERLDBf_NOOPT))
-#define PERLDB_INTER (PL_perldb && (PL_perldb & PERLDBf_INTER))
-#define PERLDB_SUBLINE (PL_perldb && (PL_perldb & PERLDBf_SUBLINE))
-#define PERLDB_SINGLE (PL_perldb && (PL_perldb & PERLDBf_SINGLE))
-#define PERLDB_SUB_NN (PL_perldb && (PL_perldb & (PERLDBf_NONAME)))
-#define PERLDB_GOTO (PL_perldb && (PL_perldb & PERLDBf_GOTO))
-#define PERLDB_NAMEEVAL (PL_perldb && (PL_perldb & PERLDBf_NAMEEVAL))
-#define PERLDB_NAMEANON (PL_perldb && (PL_perldb & PERLDBf_NAMEANON))
-#define PERLDB_SAVESRC (PL_perldb && (PL_perldb & PERLDBf_SAVESRC))
-#define PERLDB_SAVESRC_NOSUBS (PL_perldb && (PL_perldb & PERLDBf_SAVESRC_NOSUBS))
-#define PERLDB_SAVESRC_INVALID (PL_perldb && (PL_perldb & PERLDBf_SAVESRC_INVALID))
+#define PERLDB_SUB (PL_perldb & PERLDBf_SUB)
+#define PERLDB_LINE (PL_perldb & PERLDBf_LINE)
+#define PERLDB_NOOPT (PL_perldb & PERLDBf_NOOPT)
+#define PERLDB_INTER (PL_perldb & PERLDBf_INTER)
+#define PERLDB_SUBLINE (PL_perldb & PERLDBf_SUBLINE)
+#define PERLDB_SINGLE (PL_perldb & PERLDBf_SINGLE)
+#define PERLDB_SUB_NN (PL_perldb & PERLDBf_NONAME)
+#define PERLDB_GOTO (PL_perldb & PERLDBf_GOTO)
+#define PERLDB_NAMEEVAL (PL_perldb & PERLDBf_NAMEEVAL)
+#define PERLDB_NAMEANON (PL_perldb & PERLDBf_NAMEANON)
+#define PERLDB_SAVESRC (PL_perldb & PERLDBf_SAVESRC)
+#define PERLDB_SAVESRC_NOSUBS (PL_perldb & PERLDBf_SAVESRC_NOSUBS)
+#define PERLDB_SAVESRC_INVALID (PL_perldb & PERLDBf_SAVESRC_INVALID)
#ifdef USE_LOCALE
/* These locale things are all subject to change */
last = (PerlIOl **) (f);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
if (!((++f)->next)) {
- f->flags = 0; /* lockcnt */
- f->tab = NULL;
- f->head = f;
- return (PerlIO *)f;
+ goto good_exit;
}
}
}
return NULL;
}
*last = (PerlIOl*) f++;
+
+ good_exit:
f->flags = 0; /* lockcnt */
f->tab = NULL;
f->head = f;
else {
STRLEN len;
const char * const name = SvPV_const(ST(1), len);
- const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
+ const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
ST(0) =
(layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
tab = &PerlIO_stdio;
#endif
PerlIO_debug("Pushing %s\n", tab->name);
- PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
- &PL_sv_undef);
+ PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
}
SV *
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
- PerlIO_list_push(aTHX_ PL_def_layerlist,
- PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
- &PL_sv_undef);
+ PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
+ &PL_sv_undef);
if (s) {
PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
}
* If it is a reference but not an object see if we have a handler
* for it
*/
- if (SvROK(arg) && !sv_isobject(arg)) {
+ if (SvROK(arg) && !SvOBJECT(SvRV(arg))) {
PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
if (handler) {
def = PerlIO_list_alloc(aTHX);
if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
SETERRNO(EBADF, SS_IVCHAN);
+ PerlIO_save_errno(f);
return 0;
}
while (count > 0) {
if (len < 0) {
if (errno != EAGAIN) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ PerlIO_save_errno(f);
}
}
else if (len == 0 && count != 0) {
if (len < 0) {
if (errno != EAGAIN) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ PerlIO_save_errno(f);
}
}
return len;
{
dTHX;
PerlIO *f = NULL;
+#ifdef EBCDIC
+ int rc;
+ char filename[FILENAME_MAX];
+ fldata_t fileinfo;
+#endif
if (stdio) {
PerlIOStdio *s;
int fd0 = fileno(stdio);
if (fd0 < 0) {
+#ifdef EBCDIC
+ rc = fldata(stdio,filename,&fileinfo);
+ if(rc != 0){
+ return NULL;
+ }
+ if(fileinfo.__dsorgHFS){
+ return NULL;
+ }
+ /*This MVS dataset , OK!*/
+#else
return NULL;
+#endif
}
if (!mode || !*mode) {
/* We need to probe to see how we can open the stream
if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
s = PerlIOSelf(f, PerlIOStdio);
s->stdio = stdio;
+#ifdef EBCDIC
+ fd0 = fileno(stdio);
+ if(fd0 != -1){
+ PerlIOUnix_refcnt_inc(fd0);
+ }
+ else{
+ rc = fldata(stdio,filename,&fileinfo);
+ if(rc != 0){
+ PerlIOUnix_refcnt_inc(fd0);
+ }
+ if(fileinfo.__dsorgHFS){
+ PerlIOUnix_refcnt_inc(fd0);
+ }
+ /*This MVS dataset , OK!*/
+ }
+#else
PerlIOUnix_refcnt_inc(fileno(stdio));
+#endif
}
}
return f;
}
else if (count < 0 || PerlIO_error(n)) {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ PerlIO_save_errno(f);
code = -1;
break;
}
if (avail == 0)
PerlIOBase(f)->flags |= PERLIO_F_EOF;
else
+ {
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ PerlIO_save_errno(f);
+ }
return -1;
}
b->end = b->buf + avail;
return f;
}
+void
+Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
+{
+ if (!PerlIOValid(f))
+ return;
+ PerlIOBase(f)->err = errno;
+#ifdef VMS
+ PerlIOBase(f)->os_err = vaxc$errno;
+#elif defined(OS2)
+ PerlIOBase(f)->os_err = Perl_rc;
+#elif defined(WIN32)
+ PerlIOBase(f)->os_err = GetLastError();
+#endif
+}
+
+void
+Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
+{
+ if (!PerlIOValid(f))
+ return;
+ SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
+#ifdef OS2
+ Perl_rc = PerlIOBase(f)->os_err);
+#elif defined(WIN32)
+ SetLastError(PerlIOBase(f)->os_err);
+#endif
+}
+
#undef HAS_FSETPOS
#undef HAS_FGETPOS
PerlIO_setpos(PerlIO *f, SV *pos)
{
if (SvOK(pos)) {
- STRLEN len;
- dTHX;
- const Off_t * const posn = (Off_t *) SvPV(pos, len);
- if (f && len == sizeof(Off_t))
- return PerlIO_seek(f, *posn, SEEK_SET);
+ if (f) {
+ dTHX;
+ STRLEN len;
+ const Off_t * const posn = (Off_t *) SvPV(pos, len);
+ if(len == sizeof(Off_t))
+ return PerlIO_seek(f, *posn, SEEK_SET);
+ }
}
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
int
PerlIO_setpos(PerlIO *f, SV *pos)
{
- dTHX;
if (SvOK(pos)) {
- STRLEN len;
- Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
- if (f && len == sizeof(Fpos_t)) {
+ if (f) {
+ dTHX;
+ STRLEN len;
+ Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
+ if(len == sizeof(Fpos_t))
#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
- return fsetpos64(f, fpos);
+ return fsetpos64(f, fpos);
#else
- return fsetpos(f, fpos);
+ return fsetpos(f, fpos);
#endif
}
}
#endif
+/* print a failure format string message to stderr and fail exit the process
+ using only libc without depending on any perl data structures being
+ initialized.
+*/
+
+void
+Perl_noperl_die(const char* pat, ...)
+{
+ va_list(arglist);
+ PERL_ARGS_ASSERT_NOPERL_DIE;
+ va_start(arglist, pat);
+ vfprintf(stderr, pat, arglist);
+ va_end(arglist);
+ exit(1);
+}
+
/*
* Local variables:
* c-indentation-style: bsd
PerlIOl *next; /* Lower layer */
PerlIO_funcs *tab; /* Functions for this layer */
U32 flags; /* Various flags for state */
+ int err; /* Saved errno value */
+#ifdef VMS
+ unsigned os_err; /* Saved vaxc$errno value */
+#elif defined (OS2)
+ unsigned long os_err;
+#elif defined (WIN32)
+ DWORD os_err; /* Saved GetLastError() value */
+#endif
PerlIOl *head; /* our ultimate parent pointer */
};
#line 119 "perly.y"
{
newPROG(block_end((ps[(3) - (4)].val.ival),(ps[(4) - (4)].val.opval)));
+ PL_compiling.cop_seq = 0;
(yyval.ival) = 0;
;}
break;
case 4:
-#line 124 "perly.y"
+#line 125 "perly.y"
{
parser->expect = XTERM;
;}
break;
case 5:
-#line 128 "perly.y"
+#line 129 "perly.y"
{
PL_eval_root = (ps[(3) - (3)].val.opval);
(yyval.ival) = 0;
break;
case 6:
-#line 133 "perly.y"
+#line 134 "perly.y"
{
parser->expect = XBLOCK;
;}
break;
case 7:
-#line 137 "perly.y"
+#line 138 "perly.y"
{
PL_pad_reset_pending = TRUE;
PL_eval_root = (ps[(3) - (3)].val.opval);
break;
case 8:
-#line 145 "perly.y"
+#line 146 "perly.y"
{
parser->expect = XSTATE;
;}
break;
case 9:
-#line 149 "perly.y"
+#line 150 "perly.y"
{
PL_pad_reset_pending = TRUE;
PL_eval_root = (ps[(3) - (3)].val.opval);
break;
case 10:
-#line 157 "perly.y"
+#line 158 "perly.y"
{
parser->expect = XSTATE;
;}
break;
case 11:
-#line 161 "perly.y"
+#line 162 "perly.y"
{
PL_pad_reset_pending = TRUE;
PL_eval_root = (ps[(3) - (3)].val.opval);
break;
case 12:
-#line 169 "perly.y"
+#line 170 "perly.y"
{
parser->expect = XSTATE;
;}
break;
case 13:
-#line 173 "perly.y"
+#line 174 "perly.y"
{
PL_eval_root = (ps[(3) - (3)].val.opval);
(yyval.ival) = 0;
break;
case 14:
-#line 181 "perly.y"
+#line 182 "perly.y"
{ 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 189 "perly.y"
+#line 190 "perly.y"
{ 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 196 "perly.y"
+#line 197 "perly.y"
{ (yyval.ival) = block_start(TRUE); ;}
break;
case 17:
-#line 200 "perly.y"
+#line 201 "perly.y"
{ 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 207 "perly.y"
+#line 208 "perly.y"
{ (yyval.ival) = block_start(FALSE); ;}
break;
case 19:
-#line 212 "perly.y"
+#line 213 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 20:
-#line 214 "perly.y"
+#line 215 "perly.y"
{ (yyval.opval) = op_append_list(OP_LINESEQ, (ps[(1) - (2)].val.opval), (ps[(2) - (2)].val.opval));
PL_pad_reset_pending = TRUE;
if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval))
break;
case 21:
-#line 223 "perly.y"
+#line 224 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 22:
-#line 225 "perly.y"
+#line 226 "perly.y"
{ (yyval.opval) = op_append_list(OP_LINESEQ, (ps[(1) - (2)].val.opval), (ps[(2) - (2)].val.opval));
PL_pad_reset_pending = TRUE;
if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval))
break;
case 23:
-#line 234 "perly.y"
+#line 235 "perly.y"
{
(yyval.opval) = (ps[(1) - (1)].val.opval) ? newSTATEOP(0, NULL, (ps[(1) - (1)].val.opval)) : NULL;
;}
break;
case 24:
-#line 238 "perly.y"
+#line 239 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 25:
-#line 242 "perly.y"
+#line 243 "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 246 "perly.y"
+#line 247 "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 253 "perly.y"
+#line 254 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 28:
-#line 255 "perly.y"
+#line 256 "perly.y"
{
CV *fmtcv = PL_compcv;
newFORM((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval), (ps[(4) - (4)].val.opval));
break;
case 29:
-#line 265 "perly.y"
+#line 266 "perly.y"
{
if ((ps[(2) - (3)].val.opval)->op_type == OP_CONST) {
const char *const name =
break;
case 30:
-#line 287 "perly.y"
+#line 288 "perly.y"
{
SvREFCNT_inc_simple_void(PL_compcv);
(ps[(2) - (7)].val.opval)->op_type == OP_CONST
break;
case 31:
-#line 297 "perly.y"
+#line 298 "perly.y"
{
package((ps[(3) - (4)].val.opval));
if ((ps[(2) - (4)].val.opval))
break;
case 32:
-#line 304 "perly.y"
+#line 305 "perly.y"
{ CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ ;}
break;
case 33:
-#line 306 "perly.y"
+#line 307 "perly.y"
{
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));
break;
case 34:
-#line 312 "perly.y"
+#line 313 "perly.y"
{
(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)));
break;
case 35:
-#line 318 "perly.y"
+#line 319 "perly.y"
{
(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)));
break;
case 36:
-#line 324 "perly.y"
+#line 325 "perly.y"
{
const PADOFFSET offset = pad_findmy_pvs("$_", 0);
(yyval.opval) = block_end((ps[(3) - (6)].val.ival),
break;
case 37:
-#line 335 "perly.y"
+#line 336 "perly.y"
{ (yyval.opval) = block_end((ps[(3) - (6)].val.ival), newWHENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)))); ;}
break;
case 38:
-#line 337 "perly.y"
+#line 338 "perly.y"
{ (yyval.opval) = newWHENOP(0, op_scope((ps[(2) - (2)].val.opval))); ;}
break;
case 39:
-#line 339 "perly.y"
+#line 340 "perly.y"
{
(yyval.opval) = block_end((ps[(3) - (8)].val.ival),
newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
break;
case 40:
-#line 346 "perly.y"
+#line 347 "perly.y"
{
(yyval.opval) = block_end((ps[(3) - (8)].val.ival),
newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
break;
case 41:
-#line 353 "perly.y"
+#line 354 "perly.y"
{ parser->expect = XTERM; ;}
break;
case 42:
-#line 355 "perly.y"
+#line 356 "perly.y"
{ parser->expect = XTERM; ;}
break;
case 43:
-#line 358 "perly.y"
+#line 359 "perly.y"
{
OP *initop = (ps[(4) - (13)].val.opval);
OP *forop = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
break;
case 44:
-#line 372 "perly.y"
+#line 373 "perly.y"
{
(yyval.opval) = block_end((ps[(3) - (9)].val.ival), newFOROP(0, (ps[(4) - (9)].val.opval), (ps[(6) - (9)].val.opval), (ps[(8) - (9)].val.opval), (ps[(9) - (9)].val.opval)));
parser->copline = (line_t)(ps[(1) - (9)].val.ival);
break;
case 45:
-#line 377 "perly.y"
+#line 378 "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)));
break;
case 46:
-#line 383 "perly.y"
+#line 384 "perly.y"
{ parser->in_my = 0; (yyval.opval) = my((ps[(5) - (5)].val.opval)); ;}
break;
case 47:
-#line 385 "perly.y"
+#line 386 "perly.y"
{
(yyval.opval) = block_end(
(ps[(4) - (11)].val.ival),
newFOROP(0,
op_lvalue(
newUNOP(OP_REFGEN, 0,
- op_lvalue((ps[(6) - (11)].val.opval),
- OP_REFGEN)),
+ (ps[(6) - (11)].val.opval)),
OP_ENTERLOOP),
(ps[(8) - (11)].val.opval), (ps[(10) - (11)].val.opval), (ps[(11) - (11)].val.opval))
);
{
(yyval.opval) = block_end((ps[(5) - (9)].val.ival), newFOROP(
0, op_lvalue(newUNOP(OP_REFGEN, 0,
- op_lvalue((ps[(3) - (9)].val.opval),
- OP_REFGEN)),
+ (ps[(3) - (9)].val.opval)),
OP_ENTERLOOP), (ps[(6) - (9)].val.opval), (ps[(8) - (9)].val.opval), (ps[(9) - (9)].val.opval)));
parser->copline = (line_t)(ps[(1) - (9)].val.ival);
;}
break;
case 49:
-#line 408 "perly.y"
+#line 407 "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)));
break;
case 50:
-#line 414 "perly.y"
+#line 413 "perly.y"
{
/* a block is a loop that happens once */
(yyval.opval) = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
break;
case 51:
-#line 420 "perly.y"
+#line 419 "perly.y"
{
package((ps[(3) - (5)].val.opval));
if ((ps[(2) - (5)].val.opval)) {
break;
case 52:
-#line 427 "perly.y"
+#line 426 "perly.y"
{
/* a block is a loop that happens once */
(yyval.opval) = newWHILEOP(0, 1, (LOOP*)(OP*)NULL,
break;
case 53:
-#line 435 "perly.y"
+#line 434 "perly.y"
{
(yyval.opval) = (ps[(1) - (2)].val.opval);
;}
break;
case 54:
-#line 439 "perly.y"
+#line 438 "perly.y"
{
(yyval.opval) = (OP*)NULL;
parser->copline = NOLINE;
break;
case 55:
-#line 447 "perly.y"
+#line 446 "perly.y"
{ OP *list;
if ((ps[(2) - (2)].val.opval)) {
OP *term = (ps[(2) - (2)].val.opval);
parser->copline = CopLINE(PL_curcop)-1;
else parser->copline--;
(yyval.opval) = newSTATEOP(0, NULL,
- convert(OP_FORMLINE, 0, list));
+ op_convert_list(OP_FORMLINE, 0, list));
;}
break;
case 56:
-#line 464 "perly.y"
+#line 463 "perly.y"
{ (yyval.opval) = NULL; ;}
break;
case 57:
-#line 466 "perly.y"
+#line 465 "perly.y"
{ (yyval.opval) = op_unscope((ps[(2) - (3)].val.opval)); ;}
break;
case 58:
-#line 471 "perly.y"
+#line 470 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 59:
-#line 473 "perly.y"
+#line 472 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 60:
-#line 475 "perly.y"
+#line 474 "perly.y"
{ (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;}
break;
case 61:
-#line 477 "perly.y"
+#line 476 "perly.y"
{ (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;}
break;
case 62:
-#line 479 "perly.y"
+#line 478 "perly.y"
{ (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[(3) - (3)].val.opval)), (ps[(1) - (3)].val.opval)); ;}
break;
case 63:
-#line 481 "perly.y"
+#line 480 "perly.y"
{ (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;}
break;
case 64:
-#line 483 "perly.y"
+#line 482 "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 65:
-#line 486 "perly.y"
+#line 485 "perly.y"
{ (yyval.opval) = newWHENOP((ps[(3) - (3)].val.opval), op_scope((ps[(1) - (3)].val.opval))); ;}
break;
case 66:
-#line 491 "perly.y"
+#line 490 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 67:
-#line 493 "perly.y"
+#line 492 "perly.y"
{
((ps[(2) - (2)].val.opval))->op_flags |= OPf_PARENS;
(yyval.opval) = op_scope((ps[(2) - (2)].val.opval));
break;
case 68:
-#line 498 "perly.y"
+#line 497 "perly.y"
{ parser->copline = (line_t)(ps[(1) - (6)].val.ival);
(yyval.opval) = newCONDOP(0,
newSTATEOP(OPf_SPECIAL,NULL,(ps[(3) - (6)].val.opval)),
break;
case 69:
-#line 508 "perly.y"
+#line 507 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 70:
-#line 510 "perly.y"
+#line 509 "perly.y"
{ (yyval.opval) = op_scope((ps[(2) - (2)].val.opval)); ;}
break;
case 71:
-#line 515 "perly.y"
+#line 514 "perly.y"
{ (yyval.ival) = (PL_min_intro_pending &&
PL_max_intro_pending >= PL_min_intro_pending);
intro_my(); ;}
break;
case 72:
-#line 521 "perly.y"
+#line 520 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 74:
-#line 527 "perly.y"
+#line 526 "perly.y"
{ YYSTYPE tmplval;
(void)scan_num("1", &tmplval);
(yyval.opval) = tmplval.opval; ;}
break;
case 76:
-#line 535 "perly.y"
+#line 534 "perly.y"
{ (yyval.opval) = invert(scalar((ps[(1) - (1)].val.opval))); ;}
break;
case 77:
-#line 540 "perly.y"
+#line 539 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;}
break;
case 78:
-#line 544 "perly.y"
+#line 543 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;}
break;
case 79:
-#line 548 "perly.y"
+#line 547 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;}
break;
case 80:
-#line 551 "perly.y"
+#line 550 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 81:
-#line 552 "perly.y"
+#line 551 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 82:
-#line 556 "perly.y"
+#line 555 "perly.y"
{ (yyval.ival) = start_subparse(FALSE, 0);
SAVEFREESV(PL_compcv); ;}
break;
case 83:
-#line 562 "perly.y"
+#line 561 "perly.y"
{ (yyval.ival) = start_subparse(FALSE, CVf_ANON);
SAVEFREESV(PL_compcv); ;}
break;
case 84:
-#line 567 "perly.y"
+#line 566 "perly.y"
{ (yyval.ival) = start_subparse(TRUE, 0);
SAVEFREESV(PL_compcv); ;}
break;
case 87:
-#line 578 "perly.y"
+#line 577 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 89:
-#line 584 "perly.y"
+#line 583 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 90:
-#line 586 "perly.y"
+#line 585 "perly.y"
{ (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
break;
case 91:
-#line 588 "perly.y"
+#line 587 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 92:
-#line 593 "perly.y"
+#line 592 "perly.y"
{ (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
break;
case 93:
-#line 595 "perly.y"
+#line 594 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 94:
-#line 599 "perly.y"
+#line 598 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 95:
-#line 601 "perly.y"
+#line 600 "perly.y"
{
if (!FEATURE_SIGNATURES_IS_ENABLED)
Perl_croak(aTHX_ "Experimental "
break;
case 96:
-#line 611 "perly.y"
+#line 610 "perly.y"
{
(yyval.opval) = op_append_list(OP_LINESEQ, (ps[(2) - (3)].val.opval),
newSTATEOP(0, NULL, sawparens(newNULLLIST())));
break;
case 97:
-#line 620 "perly.y"
+#line 619 "perly.y"
{
if (parser->copline > (line_t)(ps[(3) - (5)].val.ival))
parser->copline = (line_t)(ps[(3) - (5)].val.ival);
break;
case 98:
-#line 629 "perly.y"
+#line 628 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 99:
-#line 630 "perly.y"
+#line 629 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 100:
-#line 635 "perly.y"
+#line 634 "perly.y"
{ (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 101:
-#line 637 "perly.y"
+#line 636 "perly.y"
{ (yyval.opval) = newLOGOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 102:
-#line 639 "perly.y"
+#line 638 "perly.y"
{ (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 104:
-#line 645 "perly.y"
+#line 644 "perly.y"
{ (yyval.opval) = (ps[(1) - (2)].val.opval); ;}
break;
case 105:
-#line 647 "perly.y"
+#line 646 "perly.y"
{
OP* term = (ps[(3) - (3)].val.opval);
(yyval.opval) = op_append_elem(OP_LIST, (ps[(1) - (3)].val.opval), term);
break;
case 107:
-#line 656 "perly.y"
- { (yyval.opval) = convert((ps[(1) - (3)].val.ival), OPf_STACKED,
+#line 655 "perly.y"
+ { (yyval.opval) = op_convert_list((ps[(1) - (3)].val.ival), OPf_STACKED,
op_prepend_elem(OP_LIST, newGVREF((ps[(1) - (3)].val.ival),(ps[(2) - (3)].val.opval)), (ps[(3) - (3)].val.opval)) );
;}
break;
case 108:
-#line 660 "perly.y"
- { (yyval.opval) = convert((ps[(1) - (5)].val.ival), OPf_STACKED,
+#line 659 "perly.y"
+ { (yyval.opval) = op_convert_list((ps[(1) - (5)].val.ival), OPf_STACKED,
op_prepend_elem(OP_LIST, newGVREF((ps[(1) - (5)].val.ival),(ps[(3) - (5)].val.opval)), (ps[(4) - (5)].val.opval)) );
;}
break;
case 109:
-#line 664 "perly.y"
- { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED,
+#line 663 "perly.y"
+ { (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, scalar((ps[(1) - (6)].val.opval)), (ps[(5) - (6)].val.opval)),
newMETHOP(OP_METHOD, 0, (ps[(3) - (6)].val.opval))));
break;
case 110:
-#line 670 "perly.y"
- { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED,
+#line 669 "perly.y"
+ { (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, scalar((ps[(1) - (3)].val.opval)),
newMETHOP(OP_METHOD, 0, (ps[(3) - (3)].val.opval))));
;}
break;
case 111:
-#line 675 "perly.y"
- { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED,
+#line 674 "perly.y"
+ { (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, (ps[(2) - (3)].val.opval), (ps[(3) - (3)].val.opval)),
newMETHOP(OP_METHOD, 0, (ps[(1) - (3)].val.opval))));
break;
case 112:
-#line 681 "perly.y"
- { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED,
+#line 680 "perly.y"
+ { (yyval.opval) = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, (ps[(2) - (5)].val.opval), (ps[(4) - (5)].val.opval)),
newMETHOP(OP_METHOD, 0, (ps[(1) - (5)].val.opval))));
break;
case 113:
-#line 687 "perly.y"
- { (yyval.opval) = convert((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;}
+#line 686 "perly.y"
+ { (yyval.opval) = op_convert_list((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;}
break;
case 114:
-#line 689 "perly.y"
- { (yyval.opval) = convert((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); ;}
+#line 688 "perly.y"
+ { (yyval.opval) = op_convert_list((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); ;}
break;
case 115:
-#line 691 "perly.y"
+#line 690 "perly.y"
{ SvREFCNT_inc_simple_void(PL_compcv);
(yyval.opval) = newANONATTRSUB((ps[(2) - (3)].val.ival), 0, (OP*)NULL, (ps[(3) - (3)].val.opval)); ;}
break;
case 116:
-#line 694 "perly.y"
+#line 693 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)), (ps[(1) - (5)].val.opval)));
break;
case 119:
-#line 709 "perly.y"
+#line 708 "perly.y"
{ (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[(1) - (5)].val.opval), scalar((ps[(3) - (5)].val.opval))); ;}
break;
case 120:
-#line 711 "perly.y"
+#line 710 "perly.y"
{ (yyval.opval) = newBINOP(OP_AELEM, 0, oopsAV((ps[(1) - (4)].val.opval)), scalar((ps[(3) - (4)].val.opval)));
;}
break;
case 121:
-#line 714 "perly.y"
+#line 713 "perly.y"
{ (yyval.opval) = newBINOP(OP_AELEM, 0,
ref(newAVREF((ps[(1) - (5)].val.opval)),OP_RV2AV),
scalar((ps[(4) - (5)].val.opval)));
break;
case 122:
-#line 719 "perly.y"
+#line 718 "perly.y"
{ (yyval.opval) = newBINOP(OP_AELEM, 0,
ref(newAVREF((ps[(1) - (4)].val.opval)),OP_RV2AV),
scalar((ps[(3) - (4)].val.opval)));
break;
case 123:
-#line 724 "perly.y"
+#line 723 "perly.y"
{ (yyval.opval) = newBINOP(OP_HELEM, 0, oopsHV((ps[(1) - (5)].val.opval)), jmaybe((ps[(3) - (5)].val.opval)));
;}
break;
case 124:
-#line 727 "perly.y"
+#line 726 "perly.y"
{ (yyval.opval) = newBINOP(OP_HELEM, 0,
ref(newHVREF((ps[(1) - (6)].val.opval)),OP_RV2HV),
jmaybe((ps[(4) - (6)].val.opval))); ;}
break;
case 125:
-#line 731 "perly.y"
+#line 730 "perly.y"
{ (yyval.opval) = newBINOP(OP_HELEM, 0,
ref(newHVREF((ps[(1) - (5)].val.opval)),OP_RV2HV),
jmaybe((ps[(3) - (5)].val.opval))); ;}
break;
case 126:
-#line 735 "perly.y"
+#line 734 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar((ps[(1) - (4)].val.opval)))); ;}
break;
case 127:
-#line 738 "perly.y"
+#line 737 "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))))); ;}
break;
case 128:
-#line 743 "perly.y"
+#line 742 "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 129:
-#line 747 "perly.y"
+#line 746 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar((ps[(1) - (3)].val.opval)))); ;}
break;
case 130:
-#line 750 "perly.y"
+#line 749 "perly.y"
{ (yyval.opval) = newSLICEOP(0, (ps[(5) - (6)].val.opval), (ps[(2) - (6)].val.opval)); ;}
break;
case 131:
-#line 752 "perly.y"
+#line 751 "perly.y"
{ (yyval.opval) = newSLICEOP(0, (ps[(3) - (4)].val.opval), (ps[(1) - (4)].val.opval)); ;}
break;
case 132:
-#line 754 "perly.y"
+#line 753 "perly.y"
{ (yyval.opval) = newSLICEOP(0, (ps[(4) - (5)].val.opval), (OP*)NULL); ;}
break;
case 133:
-#line 759 "perly.y"
+#line 758 "perly.y"
{ (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[(1) - (3)].val.opval), (ps[(2) - (3)].val.ival), (ps[(3) - (3)].val.opval)); ;}
break;
case 134:
-#line 761 "perly.y"
+#line 760 "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 763 "perly.y"
+#line 762 "perly.y"
{ if ((ps[(2) - (3)].val.ival) != OP_REPEAT)
scalar((ps[(1) - (3)].val.opval));
(yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), scalar((ps[(3) - (3)].val.opval)));
break;
case 136:
-#line 768 "perly.y"
+#line 767 "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 770 "perly.y"
+#line 769 "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 772 "perly.y"
+#line 771 "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 774 "perly.y"
+#line 773 "perly.y"
{ (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 140:
-#line 776 "perly.y"
+#line 775 "perly.y"
{ (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 141:
-#line 778 "perly.y"
+#line 777 "perly.y"
{ (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 142:
-#line 780 "perly.y"
+#line 779 "perly.y"
{ (yyval.opval) = newRANGE((ps[(2) - (3)].val.ival), scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;}
break;
case 143:
-#line 782 "perly.y"
+#line 781 "perly.y"
{ (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 144:
-#line 784 "perly.y"
+#line 783 "perly.y"
{ (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 145:
-#line 786 "perly.y"
+#line 785 "perly.y"
{ (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 146:
-#line 788 "perly.y"
+#line 787 "perly.y"
{ (yyval.opval) = bind_match((ps[(2) - (3)].val.ival), (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;}
break;
case 147:
-#line 793 "perly.y"
+#line 792 "perly.y"
{ (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[(2) - (2)].val.opval))); ;}
break;
case 148:
-#line 795 "perly.y"
+#line 794 "perly.y"
{ (yyval.opval) = (ps[(2) - (2)].val.opval); ;}
break;
case 149:
-#line 798 "perly.y"
+#line 797 "perly.y"
{ (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); ;}
break;
case 150:
-#line 800 "perly.y"
+#line 799 "perly.y"
{ (yyval.opval) = newUNOP(OP_COMPLEMENT, 0, scalar((ps[(2) - (2)].val.opval))); ;}
break;
case 151:
-#line 802 "perly.y"
+#line 801 "perly.y"
{ (yyval.opval) = newUNOP(OP_POSTINC, 0,
op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTINC)); ;}
break;
case 152:
-#line 805 "perly.y"
+#line 804 "perly.y"
{ (yyval.opval) = newUNOP(OP_POSTDEC, 0,
op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTDEC));;}
break;
case 153:
-#line 808 "perly.y"
- { (yyval.opval) = convert(OP_JOIN, 0,
+#line 807 "perly.y"
+ { (yyval.opval) = op_convert_list(OP_JOIN, 0,
op_append_elem(
OP_LIST,
newSVREF(scalar(
break;
case 154:
-#line 819 "perly.y"
+#line 818 "perly.y"
{ (yyval.opval) = newUNOP(OP_PREINC, 0,
op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREINC)); ;}
break;
case 155:
-#line 822 "perly.y"
+#line 821 "perly.y"
{ (yyval.opval) = newUNOP(OP_PREDEC, 0,
op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREDEC)); ;}
break;
case 156:
-#line 829 "perly.y"
+#line 828 "perly.y"
{ (yyval.opval) = newANONLIST((ps[(2) - (3)].val.opval)); ;}
break;
case 157:
-#line 831 "perly.y"
+#line 830 "perly.y"
{ (yyval.opval) = newANONLIST((OP*)NULL);;}
break;
case 158:
-#line 833 "perly.y"
+#line 832 "perly.y"
{ (yyval.opval) = newANONHASH((ps[(2) - (4)].val.opval)); ;}
break;
case 159:
-#line 835 "perly.y"
+#line 834 "perly.y"
{ (yyval.opval) = newANONHASH((OP*)NULL); ;}
break;
case 160:
-#line 837 "perly.y"
+#line 836 "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 161:
-#line 844 "perly.y"
+#line 843 "perly.y"
{ (yyval.opval) = dofile((ps[(2) - (2)].val.opval), (ps[(1) - (2)].val.ival));;}
break;
case 162:
-#line 846 "perly.y"
+#line 845 "perly.y"
{ (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[(2) - (2)].val.opval)));;}
break;
case 167:
-#line 854 "perly.y"
+#line 853 "perly.y"
{ (yyval.opval) = newCONDOP(0, (ps[(1) - (5)].val.opval), (ps[(3) - (5)].val.opval), (ps[(5) - (5)].val.opval)); ;}
break;
case 168:
-#line 856 "perly.y"
+#line 855 "perly.y"
{ (yyval.opval) = newUNOP(OP_REFGEN, 0, op_lvalue((ps[(2) - (2)].val.opval),OP_REFGEN)); ;}
break;
case 169:
-#line 858 "perly.y"
+#line 857 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 170:
-#line 860 "perly.y"
+#line 859 "perly.y"
{ (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); ;}
break;
case 171:
-#line 862 "perly.y"
+#line 861 "perly.y"
{ (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); ;}
break;
case 172:
-#line 864 "perly.y"
+#line 863 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 173:
-#line 866 "perly.y"
+#line 865 "perly.y"
{ (yyval.opval) = sawparens(newNULLLIST()); ;}
break;
case 174:
-#line 868 "perly.y"
+#line 867 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 175:
-#line 870 "perly.y"
+#line 869 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 176:
-#line 872 "perly.y"
+#line 871 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 177:
-#line 874 "perly.y"
+#line 873 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 178:
-#line 876 "perly.y"
+#line 875 "perly.y"
{ (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[(1) - (1)].val.opval), OP_AV2ARYLEN));;}
break;
case 179:
-#line 878 "perly.y"
+#line 877 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 180:
-#line 880 "perly.y"
+#line 879 "perly.y"
{ (yyval.opval) = op_prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_ASLICE, 0,
break;
case 181:
-#line 890 "perly.y"
+#line 889 "perly.y"
{ (yyval.opval) = op_prepend_elem(OP_KVASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_KVASLICE, 0,
break;
case 182:
-#line 900 "perly.y"
+#line 899 "perly.y"
{ (yyval.opval) = op_prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
break;
case 183:
-#line 910 "perly.y"
+#line 909 "perly.y"
{ (yyval.opval) = op_prepend_elem(OP_KVHSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_KVHSLICE, 0,
break;
case 184:
-#line 920 "perly.y"
+#line 919 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 185:
-#line 922 "perly.y"
+#line 921 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[(1) - (1)].val.opval))); ;}
break;
case 186:
-#line 924 "perly.y"
+#line 923 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (3)].val.opval)));
;}
break;
case 187:
-#line 927 "perly.y"
+#line 926 "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 188:
-#line 932 "perly.y"
+#line 931 "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 189:
-#line 936 "perly.y"
+#line 935 "perly.y"
{ (yyval.opval) = newSVREF((ps[(1) - (4)].val.opval)); ;}
break;
case 190:
-#line 938 "perly.y"
+#line 937 "perly.y"
{ (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); ;}
break;
case 191:
-#line 940 "perly.y"
+#line 939 "perly.y"
{ (yyval.opval) = newHVREF((ps[(1) - (4)].val.opval)); ;}
break;
case 192:
-#line 942 "perly.y"
+#line 941 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, 0,
scalar(newCVREF((ps[(3) - (4)].val.ival),(ps[(1) - (4)].val.opval)))); ;}
break;
case 193:
-#line 945 "perly.y"
+#line 944 "perly.y"
{ (yyval.opval) = newGVREF(0,(ps[(1) - (4)].val.opval)); ;}
break;
case 194:
-#line 947 "perly.y"
+#line 946 "perly.y"
{ (yyval.opval) = newOP((ps[(1) - (1)].val.ival), OPf_SPECIAL);
PL_hints |= HINT_BLOCK_SCOPE; ;}
break;
case 195:
-#line 950 "perly.y"
+#line 949 "perly.y"
{ (yyval.opval) = newLOOPEX((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); ;}
break;
case 196:
-#line 952 "perly.y"
+#line 951 "perly.y"
{ (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); ;}
break;
case 197:
-#line 954 "perly.y"
+#line 953 "perly.y"
{ (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); ;}
break;
case 198:
-#line 956 "perly.y"
+#line 955 "perly.y"
{ (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;}
break;
case 199:
-#line 958 "perly.y"
+#line 957 "perly.y"
{ (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;}
break;
case 200:
-#line 960 "perly.y"
+#line 959 "perly.y"
{ (yyval.opval) = newOP(OP_REQUIRE, (ps[(1) - (1)].val.ival) ? OPf_SPECIAL : 0); ;}
break;
case 201:
-#line 962 "perly.y"
+#line 961 "perly.y"
{ (yyval.opval) = newUNOP(OP_REQUIRE, (ps[(1) - (2)].val.ival) ? OPf_SPECIAL : 0, (ps[(2) - (2)].val.opval)); ;}
break;
case 202:
-#line 964 "perly.y"
+#line 963 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;}
break;
case 203:
-#line 966 "perly.y"
+#line 965 "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 204:
-#line 969 "perly.y"
+#line 968 "perly.y"
{ (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); ;}
break;
case 205:
-#line 971 "perly.y"
+#line 970 "perly.y"
{ (yyval.opval) = newOP((ps[(1) - (3)].val.ival), 0);;}
break;
case 206:
-#line 973 "perly.y"
+#line 972 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 207:
-#line 975 "perly.y"
+#line 974 "perly.y"
{ (yyval.opval) = (ps[(1) - (3)].val.opval); ;}
break;
case 208:
-#line 977 "perly.y"
+#line 976 "perly.y"
{ (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;}
break;
case 209:
-#line 979 "perly.y"
+#line 978 "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 210:
-#line 983 "perly.y"
+#line 982 "perly.y"
{ (yyval.opval) = newUNOP((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); ;}
break;
case 211:
-#line 985 "perly.y"
+#line 984 "perly.y"
{
if ( (ps[(1) - (1)].val.opval)->op_type != OP_TRANS
&& (ps[(1) - (1)].val.opval)->op_type != OP_TRANSR
break;
case 212:
-#line 996 "perly.y"
+#line 995 "perly.y"
{ (yyval.opval) = pmruntime((ps[(1) - (5)].val.opval), (ps[(4) - (5)].val.opval), 1, (ps[(2) - (5)].val.ival)); ;}
break;
case 215:
-#line 1000 "perly.y"
+#line 999 "perly.y"
{
(yyval.opval) = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
newSVOP(OP_CONST, 0, newSVpvs("Unimplemented")));
break;
case 217:
-#line 1009 "perly.y"
+#line 1008 "perly.y"
{ (yyval.opval) = my_attrs((ps[(2) - (3)].val.opval),(ps[(3) - (3)].val.opval)); ;}
break;
case 218:
-#line 1011 "perly.y"
+#line 1010 "perly.y"
{ (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); ;}
break;
case 219:
-#line 1016 "perly.y"
+#line 1015 "perly.y"
{ (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); ;}
break;
case 220:
-#line 1018 "perly.y"
+#line 1017 "perly.y"
{ (yyval.opval) = sawparens(newNULLLIST()); ;}
break;
case 221:
-#line 1021 "perly.y"
+#line 1020 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 222:
-#line 1023 "perly.y"
+#line 1022 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 223:
-#line 1025 "perly.y"
+#line 1024 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 224:
-#line 1030 "perly.y"
+#line 1029 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 225:
-#line 1032 "perly.y"
+#line 1031 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 226:
-#line 1036 "perly.y"
+#line 1035 "perly.y"
{ (yyval.opval) = (OP*)NULL; ;}
break;
case 227:
-#line 1038 "perly.y"
+#line 1037 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
case 228:
-#line 1044 "perly.y"
+#line 1043 "perly.y"
{ parser->in_my = 0; (yyval.opval) = my((ps[(1) - (1)].val.opval)); ;}
break;
case 234:
-#line 1057 "perly.y"
+#line 1056 "perly.y"
{ (yyval.opval) = newCVREF((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); ;}
break;
case 235:
-#line 1061 "perly.y"
+#line 1060 "perly.y"
{ (yyval.opval) = newSVREF((ps[(2) - (2)].val.opval)); ;}
break;
case 236:
-#line 1065 "perly.y"
+#line 1064 "perly.y"
{ (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval));
if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival);
;}
break;
case 237:
-#line 1071 "perly.y"
+#line 1070 "perly.y"
{ (yyval.opval) = newHVREF((ps[(2) - (2)].val.opval));
if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival);
;}
break;
case 238:
-#line 1077 "perly.y"
+#line 1076 "perly.y"
{ (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); ;}
break;
case 239:
-#line 1079 "perly.y"
+#line 1078 "perly.y"
{ (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); ;}
break;
case 240:
-#line 1083 "perly.y"
+#line 1082 "perly.y"
{ (yyval.opval) = newGVREF(0,(ps[(2) - (2)].val.opval)); ;}
break;
case 242:
-#line 1088 "perly.y"
+#line 1087 "perly.y"
{ (yyval.opval) = newAVREF((ps[(1) - (3)].val.opval)); ;}
break;
case 244:
-#line 1093 "perly.y"
+#line 1092 "perly.y"
{ (yyval.opval) = newHVREF((ps[(1) - (3)].val.opval)); ;}
break;
case 246:
-#line 1098 "perly.y"
+#line 1097 "perly.y"
{ (yyval.opval) = newGVREF(0,(ps[(1) - (3)].val.opval)); ;}
break;
case 247:
-#line 1103 "perly.y"
+#line 1102 "perly.y"
{ (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;}
break;
case 248:
-#line 1105 "perly.y"
+#line 1104 "perly.y"
{ (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;}
break;
case 249:
-#line 1107 "perly.y"
+#line 1106 "perly.y"
{ (yyval.opval) = op_scope((ps[(1) - (1)].val.opval)); ;}
break;
case 250:
-#line 1110 "perly.y"
+#line 1109 "perly.y"
{ (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
break;
/* Generated from:
- * e00865c409632c145afdedc53ed48cbd223351eb895754d2775ff66a5aae8533 perly.y
+ * aa8cc2f0979e92f76ac0fbc21000e975a6a443beed009e907eddb57f3d8dbe6a perly.y
* d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl
* ex: set ro: */
/* Generated from:
- * e00865c409632c145afdedc53ed48cbd223351eb895754d2775ff66a5aae8533 perly.y
+ * aa8cc2f0979e92f76ac0fbc21000e975a6a443beed009e907eddb57f3d8dbe6a perly.y
* d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl
* ex: set ro: */
/* YYRLINE[YYN] -- source line where rule number YYN was defined. */
static const yytype_uint16 yyrline[] =
{
- 0, 115, 115, 114, 124, 123, 133, 132, 145, 144,
- 157, 156, 169, 168, 180, 188, 196, 199, 207, 212,
- 213, 223, 224, 233, 237, 241, 245, 252, 254, 265,
- 264, 296, 304, 303, 311, 317, 323, 334, 336, 338,
- 345, 353, 355, 352, 371, 376, 383, 382, 398, 407,
- 413, 420, 419, 434, 438, 446, 464, 465, 470, 472,
- 474, 476, 478, 480, 482, 485, 491, 492, 497, 508,
- 509, 515, 521, 522, 527, 530, 534, 539, 543, 547,
- 551, 552, 556, 562, 567, 572, 573, 578, 579, 584,
- 585, 587, 592, 594, 599, 601, 600, 619, 629, 630,
- 634, 636, 638, 640, 644, 646, 651, 655, 659, 663,
- 669, 674, 680, 686, 688, 691, 690, 701, 702, 706,
- 710, 713, 718, 723, 726, 730, 734, 737, 742, 746,
- 749, 751, 753, 758, 760, 762, 767, 769, 771, 773,
- 775, 777, 779, 781, 783, 785, 787, 792, 794, 797,
- 799, 801, 804, 807, 818, 821, 828, 830, 832, 834,
- 836, 843, 845, 849, 850, 851, 852, 853, 855, 857,
- 859, 861, 863, 865, 867, 869, 871, 873, 875, 877,
- 879, 889, 899, 909, 919, 921, 923, 926, 931, 935,
- 937, 939, 941, 944, 946, 949, 951, 953, 955, 957,
- 959, 961, 963, 965, 968, 970, 972, 974, 976, 978,
- 982, 985, 984, 997, 998, 999, 1004, 1008, 1010, 1015,
- 1017, 1020, 1022, 1024, 1029, 1031, 1036, 1037, 1043, 1047,
- 1048, 1049, 1052, 1053, 1056, 1060, 1064, 1070, 1076, 1078,
- 1082, 1086, 1087, 1091, 1092, 1096, 1097, 1102, 1104, 1106,
- 1109
+ 0, 115, 115, 114, 125, 124, 134, 133, 146, 145,
+ 158, 157, 170, 169, 181, 189, 197, 200, 208, 213,
+ 214, 224, 225, 234, 238, 242, 246, 253, 255, 266,
+ 265, 297, 305, 304, 312, 318, 324, 335, 337, 339,
+ 346, 354, 356, 353, 372, 377, 384, 383, 398, 406,
+ 412, 419, 418, 433, 437, 445, 463, 464, 469, 471,
+ 473, 475, 477, 479, 481, 484, 490, 491, 496, 507,
+ 508, 514, 520, 521, 526, 529, 533, 538, 542, 546,
+ 550, 551, 555, 561, 566, 571, 572, 577, 578, 583,
+ 584, 586, 591, 593, 598, 600, 599, 618, 628, 629,
+ 633, 635, 637, 639, 643, 645, 650, 654, 658, 662,
+ 668, 673, 679, 685, 687, 690, 689, 700, 701, 705,
+ 709, 712, 717, 722, 725, 729, 733, 736, 741, 745,
+ 748, 750, 752, 757, 759, 761, 766, 768, 770, 772,
+ 774, 776, 778, 780, 782, 784, 786, 791, 793, 796,
+ 798, 800, 803, 806, 817, 820, 827, 829, 831, 833,
+ 835, 842, 844, 848, 849, 850, 851, 852, 854, 856,
+ 858, 860, 862, 864, 866, 868, 870, 872, 874, 876,
+ 878, 888, 898, 908, 918, 920, 922, 925, 930, 934,
+ 936, 938, 940, 943, 945, 948, 950, 952, 954, 956,
+ 958, 960, 962, 964, 967, 969, 971, 973, 975, 977,
+ 981, 984, 983, 996, 997, 998, 1003, 1007, 1009, 1014,
+ 1016, 1019, 1021, 1023, 1028, 1030, 1035, 1036, 1042, 1046,
+ 1047, 1048, 1051, 1052, 1055, 1059, 1063, 1069, 1075, 1077,
+ 1081, 1085, 1086, 1090, 1091, 1095, 1096, 1101, 1103, 1105,
+ 1108
};
#endif
};
/* Generated from:
- * e00865c409632c145afdedc53ed48cbd223351eb895754d2775ff66a5aae8533 perly.y
+ * aa8cc2f0979e92f76ac0fbc21000e975a6a443beed009e907eddb57f3d8dbe6a perly.y
* d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl
* ex: set ro: */
remember stmtseq
{
newPROG(block_end($3,$4));
+ PL_compiling.cop_seq = 0;
$$ = 0;
}
| GRAMEXPR
newFOROP(0,
op_lvalue(
newUNOP(OP_REFGEN, 0,
- op_lvalue($<opval>6,
- OP_REFGEN)),
+ $<opval>6),
OP_ENTERLOOP),
$8, $10, $11)
);
{
$$ = block_end($5, newFOROP(
0, op_lvalue(newUNOP(OP_REFGEN, 0,
- op_lvalue($3,
- OP_REFGEN)),
+ $3),
OP_ENTERLOOP), $6, $8, $9));
parser->copline = (line_t)$1;
}
parser->copline = CopLINE(PL_curcop)-1;
else parser->copline--;
$$ = newSTATEOP(0, NULL,
- convert(OP_FORMLINE, 0, list));
+ op_convert_list(OP_FORMLINE, 0, list));
}
;
/* List operators */
listop : LSTOP indirob listexpr /* map {...} @args or print $fh @args */
- { $$ = convert($1, OPf_STACKED,
+ { $$ = op_convert_list($1, OPf_STACKED,
op_prepend_elem(OP_LIST, newGVREF($1,$2), $3) );
}
| FUNC '(' indirob expr ')' /* print ($fh @args */
- { $$ = convert($1, OPf_STACKED,
+ { $$ = op_convert_list($1, OPf_STACKED,
op_prepend_elem(OP_LIST, newGVREF($1,$3), $4) );
}
| term ARROW method '(' optexpr ')' /* $foo->bar(list) */
- { $$ = convert(OP_ENTERSUB, OPf_STACKED,
+ { $$ = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, scalar($1), $5),
newMETHOP(OP_METHOD, 0, $3)));
}
| term ARROW method /* $foo->bar */
- { $$ = convert(OP_ENTERSUB, OPf_STACKED,
+ { $$ = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, scalar($1),
newMETHOP(OP_METHOD, 0, $3)));
}
| METHOD indirob optlistexpr /* new Class @args */
- { $$ = convert(OP_ENTERSUB, OPf_STACKED,
+ { $$ = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, $2, $3),
newMETHOP(OP_METHOD, 0, $1)));
}
| FUNCMETH indirob '(' optexpr ')' /* method $object (@args) */
- { $$ = convert(OP_ENTERSUB, OPf_STACKED,
+ { $$ = op_convert_list(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST,
op_prepend_elem(OP_LIST, $2, $4),
newMETHOP(OP_METHOD, 0, $1)));
}
| LSTOP optlistexpr /* print @args */
- { $$ = convert($1, 0, $2); }
+ { $$ = op_convert_list($1, 0, $2); }
| FUNC '(' optexpr ')' /* print (@args) */
- { $$ = convert($1, 0, $3); }
+ { $$ = op_convert_list($1, 0, $3); }
| LSTOPSUB startanonsub block /* sub f(&@); f { foo } ... */
{ SvREFCNT_inc_simple_void(PL_compcv);
$<opval>$ = newANONATTRSUB($2, 0, (OP*)NULL, $3); }
{ $$ = newUNOP(OP_POSTDEC, 0,
op_lvalue(scalar($1), OP_POSTDEC));}
| term POSTJOIN /* implicit join after interpolated ->@ */
- { $$ = convert(OP_JOIN, 0,
+ { $$ = op_convert_list(OP_JOIN, 0,
op_append_elem(
OP_LIST,
newSVREF(scalar(
* 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.5" /**/
-#define PRIVLIB_EXP "/sys/lib/perl/5.21.5" /**/
+#define PRIVLIB "/sys/lib/perl/5.21.6" /**/
+#define PRIVLIB_EXP "/sys/lib/perl/5.21.6" /**/
/* 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.5/site_perl" /**/
-#define SITELIB_EXP "/sys/lib/perl/5.21.5/site_perl" /**/
-#define SITELIB_STEM "/sys/lib/perl/5.21.5/site_perl" /**/
+#define SITELIB "/sys/lib/perl/5.21.6/site_perl" /**/
+#define SITELIB_EXP "/sys/lib/perl/5.21.6/site_perl" /**/
+#define SITELIB_STEM "/sys/lib/perl/5.21.6/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='5'
+api_subversion='6'
api_version='21'
-api_versionstring='5.21.5'
+api_versionstring='5.21.6'
ar='ar'
-archlib='/sys/lib/perl5/5.21.5/386'
-archlibexp='/sys/lib/perl5/5.21.5/386'
+archlib='/sys/lib/perl5/5.21.6/386'
+archlibexp='/sys/lib/perl5/5.21.6/386'
archname64=''
archname='386'
archobjs=''
d_archlib='define'
d_asctime64='undef'
d_asctime_r='undef'
+d_asinh='undef'
+d_atanh='undef'
d_atolf='undef'
d_atoll='define'
d_attribute_deprecated='undef'
d_c99_variadic_macros='undef'
d_casti32='undef'
d_castneg='undef'
+d_cbrt='undef'
d_charvspr='define'
d_chown='define'
d_chroot='undef'
d_closedir='define'
d_cmsghdr_s='undef'
d_const='define'
+d_copysign='undef'
d_copysignl='undef'
d_cplusplus='undef'
d_crypt='undef'
d_endsent='undef'
d_endservent_r='undef'
d_eofnblk='define'
+d_erf='undef'
+d_erfc='undef'
d_eunice='undef'
+d_exp2='undef'
+d_expm1='undef'
d_faststdio='undef'
d_fchdir='undef'
d_fchmod='define'
d_fcntl_can_lock='undef'
d_fd_macros='undef'
d_fd_set='undef'
+d_fdim='undef'
d_fds_bits='undef'
d_fegetround='undef'
d_fgetpos='define'
d_flexfnam='define'
d_flock='undef'
d_flockproto='undef'
+d_fma='undef'
+d_fmax='undef'
+d_fmin='undef'
d_fork='define'
d_fp_class='undef'
d_fp_classify='undef'
d_grpasswd='undef'
d_hasmntopt='undef'
d_htonl='define'
+d_hypot='undef'
+d_ilogb='undef'
d_ilogbl='undef'
d_inc_version_list='undef'
d_index='undef'
d_isinfl='undef'
d_isnan='undef'
d_isnanl='undef'
+d_isnormal='undef'
d_j0='undef'
d_j0l='undef'
d_killpg='undef'
d_lchown='undef'
d_ldbl_dig='define'
d_ldexpl='undef'
+d_lgamma='undef'
+d_lgamma_r='undef'
d_libm_lib_version='0'
d_link='define'
+d_llrint='undef'
+d_llround='undef'
d_localtime64='undef'
d_localtime_r='undef'
d_localtime_r_needs_tzset='undef'
d_locconv='define'
d_lockf='undef'
+d_log1p='undef'
+d_log2='undef'
+d_logb='undef'
d_longdbl='define'
d_longlong='define'
+d_lrint='undef'
+d_lround='undef'
d_lseekproto='undef'
d_lstat='define'
d_madvise='undef'
d_msync='undef'
d_munmap='undef'
d_mymalloc='define'
+d_nan='undef'
d_ndbm_h_uses_prototypes='undef'
+d_nearbyint='undef'
+d_nextafter='undef'
+d_nexttoward='undef'
d_nice='undef'
d_nl_langinfo='undef'
d_nv_preserves_uv='undef'
d_readlink='define'
d_readv='define'
d_recvmsg='undef'
+d_remainder='undef'
+d_remquo='undef'
d_rename='define'
d_rewinddir='define'
+d_rint='undef'
d_rmdir='define'
+d_round='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='define'
d_sbrkproto='undef'
+d_scalbn='undef'
d_scalbnl='undef'
d_sched_yield='undef'
d_scm_rights='undef'
d_tcsetpgrp='define'
d_telldir='undef'
d_telldirproto='undef'
+d_tgamma='undef'
d_time='define'
d_timegm='undef'
d_times='define'
d_tm_tm_gmtoff='undef'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
+d_trunc='undef'
d_truncate='undef'
d_truncl='undef'
d_ttyname_r='undef'
direntrytype='struct dirent'
dlext='none'
dlsrc='dl_none.xs'
+doublekind='3'
doublesize='8'
drand01='(rand() / (double) ((unsigned long)1 << 15))'
drand48_r_proto='0'
inc_version_list_init='0'
incpath=''
inews=''
-installarchlib='/sys/lib/perl/5.21.5/386'
+installarchlib='/sys/lib/perl/5.21.6/386'
installbin='/usr/bin'
installman1dir='/sys/man/1pub'
installman3dir='/sys/man/2pub'
installprefix='/usr'
installprefixexp='/usr'
-installprivlib='/sys/lib/perl/5.21.5'
+installprivlib='/sys/lib/perl/5.21.6'
installscript='/usr/bin'
-installsitearch='/sys/lib/perl/5.21.5/site_perl/386'
+installsitearch='/sys/lib/perl/5.21.6/site_perl/386'
installsitebin='/usr/bin'
-installsitelib='/sys/lib/perl/5.21.5/site_perl'
+installsitelib='/sys/lib/perl/5.21.6/site_perl'
installstyle='lib/perl5'
installusrbinperl='undef'
installvendorarch=''
pr=''
prefix='/usr'
prefixexp='/usr'
-privlib='/sys/lib/perl/5.21.5'
-privlibexp='/sys/lib/perl/5.21.5'
+privlib='/sys/lib/perl/5.21.6'
+privlibexp='/sys/lib/perl/5.21.6'
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.5/site_perl/386'
+sitearch='/sys/lib/perl/5.21.6/site_perl/386'
sitearchexp='/sys/lib/perl/site_perl/386'
sitebin='/usr/bin'
sitebinexp='/usr/bin'
-sitelib='/sys/lib/perl/5.21.5/site_perl'
-sitelib_stem='/sys/lib/perl/5.21.5/site_perl'
-sitelibexp='/sys/lib/perl/5.21.5/site_perl'
+sitelib='/sys/lib/perl/5.21.6/site_perl'
+sitelib_stem='/sys/lib/perl/5.21.6/site_perl'
+sitelibexp='/sys/lib/perl/5.21.6/site_perl'
siteprefix='/usr'
siteprefixexp='/usr'
sizesize='4'
strerror_r_proto='0'
strings='/sys/include/ape/string.h'
submit=''
-subversion='5'
+subversion='6'
sysman='/sys/man/1pub'
tail=''
tar=''
vendorlibexp=''
vendorprefix=''
vendorprefixexp=''
-version='5.21.5'
-version_patchlevel_string='version 21 subversion 5'
+version='5.21.6'
+version_patchlevel_string='version 21 subversion 6'
versiononly='undef'
vi=''
xlibpth=''
config_argc=0
PERL_REVISION=5
PERL_VERSION=21
-PERL_SUBVERSION=5
+PERL_SUBVERSION=6
PERL_API_REVISION=5
PERL_API_VERSION=21
-PERL_API_SUBVERSION=5
+PERL_API_SUBVERSION=6
PERL_PATCHLEVEL=
PERL_CONFIG_SH=true
/roffitall
# generated
-/perl5215delta.pod
+/perl5216delta.pod
/perlapi.pod
/perlintern.pod
*.html
perlhist Perl history records
perldelta Perl changes since previous version
+ perl5215delta Perl changes in version 5.21.5
perl5214delta Perl changes in version 5.21.4
perl5213delta Perl changes in version 5.21.3
perl5212delta Perl changes in version 5.21.2
Now it has been changed, so subroutines always take precedence over barewords,
which brings it into conformity with similarly prototyped built-in functions:
- sub splat($) { ... }
+ sub splat(*) { ... }
sub foo { ... }
splat(foo); # now always splat(foo())
splat(bar); # still splat('bar') as before
--- /dev/null
+=encoding utf8
+
+=head1 NAME
+
+perl5215delta - what is new for perl v5.21.5
+
+=head1 DESCRIPTION
+
+This document describes differences between the 5.21.4 release and the 5.21.5
+release.
+
+If you are upgrading from an earlier release such as 5.21.3, first read
+L<perl5214delta>, which describes differences between 5.21.3 and 5.21.4.
+
+=head1 Core Enhancements
+
+=head2 New double-diamond operator
+
+C<<< <<>> >>> is like C<< <> >> but uses three-argument C<open> to open
+each file in @ARGV. So each element of @ARGV is an actual file name, and
+"|foo" won't be treated as a pipe open.
+
+=head2 Aliasing via reference
+
+Variables and subroutines can now be aliased by assigning to a reference:
+
+ \$c = \$d;
+ \&x = \&y;
+
+Or by using a backslash before a C<foreach> iterator variable, which is
+perhaps the most useful idiom this feature provides:
+
+ foreach \%hash (@array_of_hash_refs) { ... }
+
+This feature is experimental and must be enabled via C<use feature
+'refaliasing'>. It will warn unless the C<experimental::refaliasing>
+warnings category is disabled.
+
+See L<perlref/Assigning to References>
+
+=head2 Perl now supports POSIX 2008 locale currency additions.
+
+On platforms that are able to handle POSIX.1-2008, the
+hash returned by
+L<C<POSIX::localeconv()>|perllocale/The localeconv function>
+includes the international currency fields added by that version of the
+POSIX standard. These are
+C<int_n_cs_precedes>,
+C<int_n_sep_by_space>,
+C<int_n_sign_posn>,
+C<int_p_cs_precedes>,
+C<int_p_sep_by_space>,
+and
+C<int_p_sign_posn>.
+
+=head2 Packing infinity or not-a-number into a character is now fatal
+
+Before, when trying to pack infinity or not-a-number into a
+(signed) character, Perl would warn, and assumed you tried to
+pack C<< 0xFF >>; if you gave it as an argument to C<< chr >>,
+C<< U+FFFD >> was returned.
+
+But now, all such actions (C<< pack >>, C<< chr >>, and C<< print '%c' >>)
+result in a fatal error.
+
+=head2 Inf and NaN
+
+Many small improvements, bug fixes and added test cases for dealing
+with math related to infinity and not-a-number.
+
+=head1 Security
+
+=head2 Perl is now compiled with -fstack-protector-strong if available
+
+Perl has been compiled with the anti-stack-smashing option
+C<-fstack-protector> since 5.10.1. Now Perl uses the newer variant
+called C<-fstack-protector-strong>, if available. (This was added
+already in 5.21.4.)
+
+=head1 Deprecations
+
+=head2 Use of multiple /x regexp modifiers
+
+It is now deprecated to say something like any of the following:
+
+ qr/foo/xx;
+ /(?xax:foo)/;
+ use re qw(/amxx);
+
+That is, now C<x> should only occur once in any string of contiguous
+regular expression pattern modifiers. We do not believe there are any
+occurrences of this in all of CPAN. This is in preparation for a future
+Perl release having C</xx> mean to allow white-space for readability in
+bracketed character classes (those enclosed in square brackets:
+C<[...]>).
+
+=head1 Performance Enhancements
+
+=over 4
+
+=item *
+
+C<length> is up to 20% faster for non-magical/non-tied scalars containing a
+string if it is a non-utf8 string or if C<use bytes;> is in scope.
+
+=item *
+
+Non-magical/non-tied scalars that contain only a floating point value and are
+on most Perl builds with 64 bit integers now use 8-32 less bytes of memory
+depending on OS.
+
+=item *
+
+In C<@array = split>, the assignment can be optimized away with C<split>
+writing directly to the array. This optimisation was happening only for
+package arrays other than @_ and only
+sometimes. Now this optimisation happens
+almost all the time.
+
+=item *
+
+C<join> is now subject to constant folding. Moreover, C<join> with a
+scalar or constant for the separator and a single-item list to join is
+simplified to a stringification. The separator doesn't even get evaluated.
+
+=item *
+
+C<qq(@array)> is implemented using two ops: a stringify op and a join op.
+If the qq contains nothing but a single array, the stringification is
+optimized away.
+
+=item *
+
+C<our $var> and C<our($s,@a,%h)> in void context are no longer evaluated at
+run time. Even a whole sequence of C<our $foo;> statements will simply be
+skipped over. The same applies to C<state> variables.
+
+=back
+
+=head1 Modules and Pragmata
+
+=head2 Updated Modules and Pragmata
+
+=over 4
+
+=item *
+
+L<attributes> has been upgraded from version 0.23 to 0.24.
+
+Avoid reading beyond the end of a buffer. [perl #122629]
+
+=item *
+
+L<B> has been upgraded from version 1.51 to 1.52.
+
+=item *
+
+L<B::Concise> has been upgraded from version 0.993 to 0.994.
+
+Null ops that are part of the execution chain are now given sequence
+numbers.
+
+Private flags for nulled ops are now dumped with mnemonics as they would be
+for the non-nulled counterparts.
+
+L<B::Deparse> has been upgraded from version 1.28 to 1.29.
+
+Parenthesised arrays in lists passed to C<\> are now correctly deparsed
+with parentheses (e.g., C<\(@a, (@b), @c)> now retains the parentheses
+around @b), this preserving the flattening behaviour of referenced
+parenthesised arrays. Formerly, it only worked for one array: C<\(@a)>.
+
+C<local our> is now deparsed correctly, with the C<our> included.
+
+C<for($foo; !$bar; $baz) {...}> was deparsed without the C<!> (or C<not>).
+This has been fixed.
+
+Core keywords that conflict with lexical subroutines are now deparsed with
+the C<CORE::> prefix.
+
+C<foreach state $x (...) {...}> now deparses correctly with C<state> and
+not C<my>.
+
+C<our @array = split(...)> now deparses correctly with C<our> in those
+cases where the assignment is optimized away.
+
+=item *
+
+L<B::Debug> has been upgraded from version 1.21 to 1.22.
+
+=item *
+
+L<B::Deparse> has been upgraded from version 1.28 to 1.29.
+
+=item *
+
+L<Compress::Raw::Bzip2> has been upgraded from version 2.064 to 2.066.
+
+=item *
+
+L<Compress::Raw::Zlib> has been upgraded from version 2.065 to 2.066.
+
+=item *
+
+L<CPAN::Meta> has been upgraded from version 2.142060 to 2.142690.
+
+=item *
+
+L<DynaLoader> has been upgraded from version 1.26 to 1.27.
+
+Remove dl_nonlazy global if unused in Dynaloader. [perl #122926]
+
+=item *
+
+L<Errno> has been upgraded from version 1.20_04 to 1.21.
+
+=item *
+
+L<experimental> has been upgraded from version 0.010 to 0.012.
+
+=item *
+
+L<ExtUtils::CBuilder> has been upgraded from version 0.280219 to 0.280220.
+
+=item *
+
+L<ExtUtils::Miniperl> has been upgraded from version 1.02 to 1.03.
+
+=item *
+
+L<Fcntl> has been upgraded from version 1.11 to 1.13.
+
+Add support for the Linux pipe buffer size fcntl() commands.
+
+=item *
+
+L<feature> has been upgraded from version 1.37 to 1.38.
+
+=item *
+
+L<File::Find> has been upgraded from version 1.28 to 1.29.
+
+Slightly faster module loading time.
+
+=item *
+
+L<File::Spec> has been upgraded from version 3.50 to 3.51.
+
+=item *
+
+L<HTTP::Tiny> has been upgraded from version 0.049 to 0.050.
+
+=item *
+
+The IO-Compress set of modules has been upgraded from version 2.064 to 2.066.
+
+=item *
+
+L<JSON::PP> has been upgraded from version 2.27203 to 2.27300.
+
+=item *
+
+The libnet collection of modules has been upgraded from version 1.27 to 3.02.
+
+Support for IPv6 and SSL to Net::FTP, Net::NNTP, Net::POP3 and Net::SMTP.
+
+Improvements in Net::SMTP authentication.
+
+=item *
+
+L<Module::CoreList> has been upgraded from version 5.20140920 to 5.20141020.
+
+Updated to cover the latest releases of Perl.
+
+=item *
+
+L<Opcode> has been upgraded from version 1.28 to 1.29.
+
+=item *
+
+The PathTools module collection has been upgraded from version 3.50 to 3.51.
+
+Slightly faster module loading time.
+
+=item *
+
+L<perlfaq> has been upgraded from version 5.0150045 to version 5.0150046.
+[perl #123008]
+
+=item *
+
+L<POSIX> has been upgraded from version 1.43 to 1.45.
+
+POSIX::tmpnam() now produces a deprecation warning. [perl #122005]
+
+=item *
+
+L<re> has been upgraded from version 0.26 to 0.27.
+
+=item *
+
+L<Socket> has been upgraded from version 2.015 to 2.016.
+
+=item *
+
+L<Test::Simple> has been upgraded from version 1.001006 to 1.001008.
+
+=item *
+
+L<threads::shared> has been upgraded from version 1.46 to 1.47.
+
+=item *
+
+L<warnings> has been upgraded from version 1.26 to 1.28.
+
+=item *
+
+L<XSLoader> has been upgraded from version 0.17 to 0.18.
+
+Allow XSLoader to load modules from a different namespace.
+[perl #122455]
+
+=back
+
+=head1 Documentation
+
+=head2 Changes to Existing Documentation
+
+=head3 L<perlrecharclass>
+
+=over 4
+
+=item *
+
+Clarifications have been added to L<perlrecharclass/Character Ranges>
+to the effect that Perl guarantees that C<[A-Z]>, C<[a-z]>, C<[0-9]> and
+any subranges thereof in regular expression bracketed character classes
+are guaranteed to match exactly what a naive English speaker would
+expect them to match, even on platforms (such as EBCDIC) where special
+handling is required to accomplish this.
+
+=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<Cannot chr %f|perldiag/"Cannot chr %f">
+
+=item *
+
+L<Cannot compress %f in pack|perldiag/"Cannot compress %f in pack">
+
+=item *
+
+L<Cannot pack %f with '%c'|perldiag/"Cannot pack %f with '%c'">
+
+=item *
+
+L<Cannot print %f with '%c'|perldiag/"Cannot printf %f with '%c'">
+
+=back
+
+=head2 Changes to Existing Diagnostics
+
+=over 4
+
+=item *
+
+'"my" variable &foo::bar can't be in a package' has been reworded to say
+'subroutine' instead of 'variable'.
+
+=back
+
+=head1 Testing
+
+=over 4
+
+=item *
+
+Some regular expression tests are written in such a way that they will
+run very slowly if certain optimizations break. These tests have been
+moved into new files, F<< t/re/speed.t >> and F<< t/re/speed_thr.t >>,
+and are run with a C<< watchdog() >>.
+
+=back
+
+=head1 Platform Support
+
+=head2 Regained Platforms
+
+IRIX and Tru64 platforms are working again.
+(Some C<make test> failures remain.)
+
+=head2 Platform-Specific Notes
+
+=over 4
+
+=item EBCDIC
+
+Special handling is required on EBCDIC platforms to get C<qr/[i-j]/> to
+match only C<"i"> and C<"j">, since there are 7 characters between the
+code points for C<"i"> and C<"j">. This special handling had only been
+invoked when both ends of the range are literals. Now it is also
+invoked if any of the C<\N{...}> forms for specifying a character by
+name or Unicode code point is used instead of a literal. See
+L<perlrecharclass/Character Ranges>.
+
+=back
+
+=head1 Internal Changes
+
+=over 4
+
+=item *
+
+SVs of type SVt_NV are now bodyless when a build configure and platform allow
+it, specifically C<sizeof(NV) <= sizeof(IV)>. The bodyless trick is the same one
+as for IVs since 5.9.2, but for NVs, unlike IVs, is not guaranteed on all
+platforms and build configurations.
+
+=item *
+
+The C<$DB::single>, C<$DB::signal> and C<$DB::trace> now have set and
+get magic that stores their values as IVs and those IVs are used when
+testing their values in C<pp_dbstate>. This prevents perl from
+recursing infinity if an overloaded object is assigned to any of those
+variables. [perl #122445]
+
+=item *
+
+C<Perl_tmps_grow> which is marked as public API but undocumented has been
+removed from public API. If you use C<EXTEND_MORTAL> macro in your XS code to
+preextend the mortal stack, you are unaffected by this change.
+
+=item *
+
+C<cv_name>, which was introduced in 5.21.4, has been changed incompatibly.
+It now has a flags field that allows the caller to specify whether the name
+should be fully qualified. See L<perlapi/cv_name>.
+
+=item *
+
+Internally Perl no longer uses the C<SVs_PADMY> flag. C<SvPADMY()> now
+returns a true value for anything not marked PADTMP. C<SVs_PADMY> is now
+defined as 0.
+
+=item *
+
+The macros SETsv and SETsvUN have been removed. They were no longer used
+in the core since commit 6f1401dc2a, and have not been found present on
+CPAN.
+
+=item *
+
+The C<< SvFAKE >> bit (unused on HVs) got informally reserved by
+David Mitchell for future work on vtables.
+
+=item *
+
+The C<sv_catpvn_flags> function accepts C<SV_CATBYTES> and C<SV_CATUTF8>
+flags, which specify whether the appended string is bytes or utf8,
+respectively.
+
+=item *
+
+A new opcode class, C<< METHOP >> has been introduced, which holds
+class/method related info needed at runtime to improve performance
+of class/object method calls.
+
+C<< OP_METHOD >> and C<< OP_METHOD_NAMED >> are moved from being
+C<< UNOP/SVOP >> to being C<< METHOD >>.
+
+=back
+
+=head1 Selected Bug Fixes
+
+=over 4
+
+=item *
+
+Locking and unlocking values via L<Hash::Util> or C<Internals::SvREADONLY>
+no longer has any effect on values that are read-only to begin.
+Previously, unlocking such values could result in crashes, hangs or
+other erratic behaviour.
+
+=item *
+
+The internal C<looks_like_number> function (which L<Scalar::Util> provides
+access to) began erroneously to return true for "-e1" in 5.21.4, affecting
+also C<-'-e1'>. This has been fixed.
+
+=item *
+
+The flip-flop operator (C<..> in scalar context) would return the same
+scalar each time, unless the containing subroutine was called recursively.
+Now it always returns a new scalar. [perl #122829]
+
+=item *
+
+Some unterminated C<(?(...)...)> constructs in regular expressions would
+either crash or give erroneous error messages. C</(?(1)/> is one such
+example.
+
+=item *
+
+C<pack "w", $tied> no longer calls FETCH twice.
+
+=item *
+
+List assignments like C<($x, $z) = (1, $y)> now work correctly if $x and $y
+have been aliased by C<foreach>.
+
+=item *
+
+Some patterns including code blocks with syntax errors, such as
+C</ (?{(^{})/>, would hang or fail assertions on debugging builds. Now
+they produce errors.
+
+=item *
+
+An assertion failure when parsing C<sort> with debugging enabled has been
+fixed. [perl #122771]
+
+=item *
+
+C<*a = *b; @a = split //, $b[1]> could do a bad read and produce junk
+results.
+
+=item *
+
+In C<() = @array = split>, the C<() => at the beginning no longer confuses
+the optimizer, making it assume a limit of 1.
+
+=item *
+
+Fatal warnings no longer prevent the output of syntax errors.
+[perl #122966]
+
+=item *
+
+Fixed a NaN double to long double conversion error on VMS. For quiet NaNs
+(and only on Itanium, not Alpha) negative infinity instead of NaN was
+produced.
+
+=item *
+
+Fixed the issue that caused C<< make distclean >> to leave files behind
+that shouldn't. [perl #122820]
+
+=item *
+
+AIX now sets the length in C<< getsockopt >> correctly. [perl #120835],
+[rt #91183], [rt #85570].
+
+=item *
+
+During the pattern optimization phase, we no longer recurse into
+GOSUB/GOSTART when not SCF_DO_SUBSTR. This prevents the optimizer
+to run "forever" and exhaust all memory. [perl #122283]
+
+=item *
+
+F<< t/op/crypt.t >> now performs SHA-256 algorithm if the default one
+is disabled. [perl #121591]
+
+=item *
+
+Fixed an off-by-one error when setting the size of shared array.
+[perl #122950]
+
+=item *
+
+Fixed a bug that could cause perl to execute an infinite loop during
+compilation. [perl #122995]
+
+=back
+
+=head1 Acknowledgements
+
+Perl 5.21.5 represents approximately 4 weeks of development since Perl 5.21.4
+and contains approximately 40,000 lines of changes across 530 files from 33
+authors.
+
+Excluding auto-generated files, documentation and release tools, there were
+approximately 29,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.5:
+
+Aaron Crane, Abigail, Alberto Simões, Andrew Fresh, Chris 'BinGOs' Williams,
+Craig A. Berry, Dagfinn Ilmari Mannsåker, Daniel Dragan, David Mitchell, Doug
+Bell, Ed J, Father Chrysostomos, George Greer, Graham Knop, James E Keenan,
+Jarkko Hietaniemi, Karen Etheridge, Karl Williamson, Leon Timmermans, Lukas
+Mai, Niko Tyni, Peter Martini, Petr Písař, Rafael Garcia-Suarez, Reini Urban,
+Ricardo Signes, Shlomi Fish, Steve Hay, syber, Tony Cook, Vincent Pit, 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
+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
/ strGT(s1,s2)
strncmp(s1, s2, n) strnNE(s1, s2, n) / strnEQ(s1, s2, n)
+ memcmp(p1, p2, n) memNE(p1, p2, n)
+ !memcmp(p1, p2, n) memEQ(p1, p2, n)
+
Notice the different order of arguments to C<Copy> and C<Move> than used
in C<memcpy> and C<memmove>.
=over
-=item A sigil, followed solely by digits matching \p{POSIX_Digit}, like C<$0>,
-C<$1>, or C<$10000>.
-
-=item A sigil, followed by either a caret and a single POSIX uppercase letter,
-like C<$^V> or C<$^W>, or a sigil followed by a literal control character
-matching the C<\p{POSIX_Cntrl}> property.
-Due to a historical oddity, if not
-running under C<use utf8>, the 128 extra controls in the C<[0x80-0xff]> range
-may also be used in length one variables. The use of a literal control
-character is deprecated. Support for this form will be removed in a future
-version of perl.
-
-=item Similar to the above, a sigil, followed by bareword text in brackets,
-where the first character is either a caret followed by an uppercase letter,
-or a literal control, like C<${^GLOBAL_PHASE}> or C<${\7LOBAL_PHASE}>. The use
-of a literal control character is deprecated. Support for this form will be
-removed in a future version of perl.
-
-=item A sigil followed by a single character matching the C<\p{POSIX_Punct}>
-property, like C<$!> or C<%+>.
+=item *
+
+A sigil, followed solely by digits matching C<\p{POSIX_Digit}>, like
+C<$0>, C<$1>, or C<$10000>.
+
+=item *
+
+A sigil, followed by either a caret and a single POSIX uppercase letter,
+like C<$^V> or C<$^W>, or a sigil followed by a literal non-space,
+non-C<NUL> control character matching the C<\p{POSIX_Cntrl}> property.
+Due to a historical oddity, if not running under C<use utf8>, the 128
+characters in the C<[0x80-0xff]> range are considered to be controls,
+and may also be used in length-one variables. However, the use of
+non-graphical characters is deprecated as of v5.22, and support for them
+will be removed in a future version of perl. ASCII space characters and
+C<NUL> already aren't allowed, so this means that a single-character
+variable name with that name being any other C0 control C<[0x01-0x1F]>,
+or C<DEL> will generate a deprecated warning. Already, under C<"use
+utf8">, non-ASCII characters must match C<Perl_XIDS>. As of v5.22, when
+not under C<"use utf8"> C1 controls C<[0x80-0x9F]>, NO BREAK SPACE, and
+SOFT HYPHEN (C<SHY>)) generate a deprecated warning.
+
+=item *
+
+Similar to the above, a sigil, followed by bareword text in brackets,
+where the first character is either a caret followed by an uppercase
+letter, like C<${^GLOBAL_PHASE}> or a non-C<NUL>, non-space literal
+control like C<${\7LOBAL_PHASE}>. Like the above, when not under
+C<"use utf8">, the characters in C<[0x80-0xFF]> are considered controls, but as
+of v5.22, the use of any that are non-graphical are deprecated, and as
+of v5.20 the use of any ASCII-range literal control is deprecated.
+Support for these will be removed in a future version of perl.
+
+=item *
+
+A sigil followed by a single character matching the C<\p{POSIX_Punct}>
+property, like C<$!> or C<%+>, except the character C<"{"> doesn't work.
=back
Note that as of Perl 5.20, literal control characters in variable names
-are deprecated.
+are deprecated; and as of Perl 5.22, any other non-graphic characters
+are also deprecated.
=head2 Context
X<context> X<scalar context> X<list context>
($dev, $ino, undef, undef, $uid, $gid) = stat($file);
+As of Perl 5.22, you can also use C<(undef)x2> instead of C<undef, undef>.
+(You can also do C<($x) x 2>, which is less useful, because it assigns to
+the same variable twice, clobbering the first value assigned.)
+
List assignment in scalar context returns the number of elements
produced by the expression on the right side of the assignment:
=head1 NAME
-perldelta - what is new for perl v5.21.5
+perldelta - what is new for perl v5.21.6
=head1 DESCRIPTION
-This document describes differences between the 5.21.4 release and the 5.21.5
+This document describes differences between the 5.21.5 release and the 5.21.6
release.
-If you are upgrading from an earlier release such as 5.21.3, first read
-L<perl5214delta>, which describes differences between 5.21.3 and 5.21.4.
+If you are upgrading from an earlier release such as 5.21.4, first read
+L<perl5215delta>, which describes differences between 5.21.4 and 5.21.5.
=head1 Core Enhancements
-=head2 New double-diamond operator
+=head2 List form of pipe open implemented for Win32
-C<<< <<>> >>> is like C<< <> >> but uses three-argument C<open> to open
-each file in @ARGV. So each element of @ARGV is an actual file name, and
-"|foo" won't be treated as a pipe open.
+The list form of pipe:
-=head2 Aliasing via reference
+ open my $fh, "-|", "program", @arguments;
-Variables and subroutines can now be aliased by assigning to a reference:
+is now implemented on Win32. It has the same limitations as C<system
+LIST> on Win32, since the Win32 API doesn't accept program arguments
+as a list.
- \$c = \$d;
- \&x = \&y;
+=head2 Assignment to list repetition
-Or by using a backslash before a C<foreach> iterator variable, which is
-perhaps the most useful idiom this feature provides:
+C<(...) x ...> can now be used within a list that is assigned to, as long
+as the left-hand side is a valid lvalue. This allows C<(undef,undef,$foo)
+= that_function()> to be written as C<((undef)x2, $foo) = that_function()>.
- foreach \%hash (@array_of_hash_refs) { ... }
+=head2 C<close> now sets C<$!>
-This feature is experimental and must be enabled via C<use feature
-'refaliasing'>. It will warn unless the C<experimental::refaliasing>
-warnings category is disabled.
-
-See L<perlref/Assigning to References>
-
-=head2 Perl now supports POSIX 2008 locale currency additions.
-
-On platforms that are able to handle POSIX.1-2008, the
-hash returned by
-L<C<POSIX::localeconv()>|perllocale/The localeconv function>
-includes the international currency fields added by that version of the
-POSIX standard. These are
-C<int_n_cs_precedes>,
-C<int_n_sep_by_space>,
-C<int_n_sign_posn>,
-C<int_p_cs_precedes>,
-C<int_p_sep_by_space>,
-and
-C<int_p_sign_posn>.
-
-=head2 Packing infinity or not-a-number into a character is now fatal
-
-Before, when trying to pack infinity or not-a-number into a
-(signed) character, Perl would warn, and assumed you tried to
-pack C<< 0xFF >>; if you gave it as an argument to C<< chr >>,
-C<< U+FFFD >> was returned.
-
-But now, all such actions (C<< pack >>, C<< chr >>, and C<< print '%c' >>)
-result in a fatal error.
-
-=head2 Inf and NaN
-
-Many small improvements, bug fixes and added test cases for dealing
-with math related to infinity and not-a-number.
-
-=head1 Security
-
-=head2 Perl is now compiled with -fstack-protector-strong if available
-
-Perl has been compiled with the anti-stack-smashing option
-C<-fstack-protector> since 5.10.1. Now Perl uses the newer variant
-called C<-fstack-protector-strong>, if available. (This was added
-already in 5.21.4.)
+When an I/O error occurs, the fact that there has been an error is recorded
+in the handle. C<close> returns false for such a handle. Previously, the
+value of C<$!> would be untouched by C<close>, so the common convention of
+writing C<close $fh or die $!> did not work reliably. Now the handle
+records the value of C<$!>, too, and C<close> restores it.
=head1 Deprecations
-=head2 Use of multiple /x regexp modifiers
-
-It is now deprecated to say something like any of the following:
-
- qr/foo/xx;
- /(?xax:foo)/;
- use re qw(/amxx);
-
-That is, now C<x> should only occur once in any string of contiguous
-regular expression pattern modifiers. We do not believe there are any
-occurrences of this in all of CPAN. This is in preparation for a future
-Perl release having C</xx> mean to allow white-space for readability in
-bracketed character classes (those enclosed in square brackets:
-C<[...]>).
+=head2 Use of non-graphic characters in single-character variable names
+
+The syntax for single-character variable names is more lenient than
+for longer variable names, allowing the one-character name to be a
+punctuation character or even invisible (a non-graphic). Perl v5.20
+deprecated the ASCII-range controls as such a name. Now, all
+non-graphic characters that formerly were allowed are deprecated.
+The practical effect of this occurs only when not under C<S<"use
+utf8">>, and affects just the C1 controls (code points 0x80 through
+0xFF), NO-BREAK SPACE, and SOFT HYPHEN.
+
+=head2 Inlining of C<sub () { $var }> with observable side-effects
+
+In many cases Perl makes sub () { $var } into an inlinable constant
+subroutine, capturing the value of $var at the time the C<sub> expression
+is evaluated. This can break the closure behaviour in those cases where
+$var is subsequently modified. The subroutine won't return the new value.
+
+This usage is now deprecated in those cases where the variable could be
+modified elsewhere. Perl detects those cases and emits a deprecation
+warning. Such code will likely change in the future and stop producing a
+constant.
+
+If your variable is only modified in the place where it is declared, then
+Perl will continue to make the sub inlinable with no warnings.
+
+ sub make_constant {
+ my $var = shift;
+ return sub () { $var }; # fine
+ }
+
+ sub make_constant_deprecated {
+ my $var;
+ $var = shift;
+ return sub () { $var }; # deprecated
+ }
+
+ sub make_constant_deprecated2 {
+ my $var = shift;
+ log_that_value($var); # could modify $var
+ return sub () { $var }; # deprecated
+ }
+
+In the second example above, detecting that $var is assigned to only once
+is too hard to detect. That it happens in a spot other than the C<my>
+declaration is enough for Perl to find it suspicious.
+
+This deprecation warning happens only for a simple variable for the body of
+the sub. (A C<BEGIN> block or C<use> statement inside the sub is ignored,
+because it does not become part of the sub's body.) For more complex
+cases, such as C<sub () { do_something() if 0; $var }> the behaviour has
+changed such that inlining does not happen if the variable is modifiable
+elsewhere. Such cases should be rare.
=head1 Performance Enhancements
=item *
-C<length> is up to 20% faster for non-magical/non-tied scalars containing a
-string if it is a non-utf8 string or if C<use bytes;> is in scope.
-
-=item *
-
-Non-magical/non-tied scalars that contain only a floating point value and are
-on most Perl builds with 64 bit integers now use 8-32 less bytes of memory
-depending on OS.
+C<(...)x1>, C<("constant")x0> and C<($scalar)x0> are now optimised in list
+context. If the right-hand argument is a constant 1, the repetition
+operator disappears. If the right-hand argument is a constant 0, the whole
+expressions is optimised to the empty list, so long as the left-hand
+argument is a simple scalar or constant. C<(foo())x0> is not optimised.
=item *
-In C<@array = split>, the assignment can be optimized away with C<split>
-writing directly to the array. This optimisation was happening only for
-package arrays other than @_ and only
-sometimes. Now this optimisation happens
-almost all the time.
+C<substr> assignment is now optimised into 4-argument C<substr> at the end
+of a subroutine (or as the argument to C<return>). Previously, this
+optimisation only happened in void context.
=item *
-C<join> is now subject to constant folding. Moreover, C<join> with a
-scalar or constant for the separator and a single-item list to join is
-simplified to a stringification. The separator doesn't even get evaluated.
+Assignment to lexical variables is often optimised away. For instance, in
+C<$lexical = chr $foo>, the C<chr> operator writes directly to the lexical
+variable instead of returning a value that gets copied. This optimisation
+has been extended to C<split>, C<x> and C<vec> on the right-hand side. It
+has also been made to work with state variable initialization.
=item *
-C<qq(@array)> is implemented using two ops: a stringify op and a join op.
-If the qq contains nothing but a single array, the stringification is
-optimized away.
+In "\L...", "\Q...", etc., the extra "stringify" op is now optimised away,
+making these just as fast as C<lcfirst>, C<quotemeta>, etc.
=item *
-C<our $var> and C<our($s,@a,%h)> in void context are no longer evaluated at
-run time. Even a whole sequence of C<our $foo;> statements will simply be
-skipped over. The same applies to C<state> variables.
+Assignment to an empty list is now sometimes faster. In particular, it
+never calls C<FETCH> on tied arguments on the right-hand side, whereas it
+used to sometimes.
=back
=item *
-L<attributes> has been upgraded from version 0.23 to 0.24.
-
-Avoid reading beyond the end of a buffer. [perl #122629]
+L<B> has been upgraded from version 1.52 to 1.53.
=item *
-L<B> has been upgraded from version 1.51 to 1.52.
+L<B::Concise> has been upgraded from version 0.994 to 0.995.
=item *
-L<B::Concise> has been upgraded from version 0.993 to 0.994.
-
-Null ops that are part of the execution chain are now given sequence
-numbers.
-
-Private flags for nulled ops are now dumped with mnemonics as they would be
-for the non-nulled counterparts.
+L<B::Deparse> has been upgraded from version 1.29 to 1.30.
-L<B::Deparse> has been upgraded from version 1.28 to 1.29.
+It now deparses C<+sub : attr { ... }> correctly at the start of a
+statement. Without the initial C<+>, C<sub> would be a statement label.
-Parenthesised arrays in lists passed to C<\> are now correctly deparsed
-with parentheses (e.g., C<\(@a, (@b), @c)> now retains the parentheses
-around @b), this preserving the flattening behaviour of referenced
-parenthesised arrays. Formerly, it only worked for one array: C<\(@a)>.
+C<BEGIN> blocks are now emitted in the right place most of the time, but
+the change unfortunately introduced a regression, in that C<BEGIN> blocks
+occurring just before the end of the enclosing block may appear below it
+instead. So this change may need to be reverted if it cannot be fixed
+before Perl 5.22. [perl #77452]
-C<local our> is now deparsed correctly, with the C<our> included.
+B::Deparse no longer puts erroneous C<local> here and there, such as for
+C<LIST = tr/a//d>. [perl #119815]
-C<for($foo; !$bar; $baz) {...}> was deparsed without the C<!> (or C<not>).
-This has been fixed.
-
-Core keywords that conflict with lexical subroutines are now deparsed with
-the C<CORE::> prefix.
-
-C<foreach state $x (...) {...}> now deparses correctly with C<state> and
-not C<my>.
-
-C<our @array = split(...)> now deparses correctly with C<our> in those
-cases where the assignment is optimized away.
+Adjacent C<use> statements are no longer accidentally nested if one
+contains a C<do> block. [perl #115066]
=item *
-L<B::Debug> has been upgraded from version 1.21 to 1.22.
+L<B::Op_private> has been upgraded from version 5.021005 to 5.021006.
-=item *
-
-L<B::Deparse> has been upgraded from version 1.28 to 1.29.
+It now includes a hash named C<%ops_using>, list all op types that use a
+particular private flag.
=item *
-L<Compress::Raw::Bzip2> has been upgraded from version 2.064 to 2.066.
+L<CPAN::Meta> has been upgraded from version 2.142690 to 2.143240.
=item *
-L<Compress::Raw::Zlib> has been upgraded from version 2.065 to 2.066.
+L<CPAN::Meta::Requirements> has been upgraded from version 2.128 to 2.130.
=item *
-L<CPAN::Meta> has been upgraded from version 2.142060 to 2.142690.
+L<Devel::Peek> has been upgraded from version 1.18 to 1.19.
=item *
-L<DynaLoader> has been upgraded from version 1.26 to 1.27.
-
-Remove dl_nonlazy global if unused in Dynaloader. [perl #122926]
+L<Digest::SHA> has been upgraded from version 5.92 to 5.93.
=item *
-L<Errno> has been upgraded from version 1.20_04 to 1.21.
+L<DynaLoader> has been upgraded from version 1.27 to 1.28.
=item *
-L<experimental> has been upgraded from version 0.010 to 0.012.
+L<Encode> has been upgraded from version 2.62 to 2.64.
=item *
-L<ExtUtils::CBuilder> has been upgraded from version 0.280219 to 0.280220.
+L<experimental> has been upgraded from version 0.012 to 0.013.
=item *
-L<ExtUtils::Miniperl> has been upgraded from version 1.02 to 1.03.
+L<Exporter> has been upgraded from version 5.71 to 5.72.
=item *
-L<Fcntl> has been upgraded from version 1.11 to 1.13.
-
-Add support for the Linux pipe buffer size fcntl() commands.
+L<ExtUtils::MakeMaker> has been upgraded from version 6.98 to 7.02.
=item *
-L<feature> has been upgraded from version 1.37 to 1.38.
+L<ExtUtils::Manifest> has been upgraded from version 1.68 to 1.69.
=item *
-L<File::Find> has been upgraded from version 1.28 to 1.29.
-
-Slightly faster module loading time.
+L<ExtUtils::ParseXS> has been upgraded from version 3.25 to 3.26.
=item *
-L<File::Spec> has been upgraded from version 3.50 to 3.51.
+L<HTTP::Tiny> has been upgraded from version 0.050 to 0.051.
=item *
-L<HTTP::Tiny> has been upgraded from version 0.049 to 0.050.
+L<I18N::Langinfo> has been upgraded from version 0.11 to 0.12.
=item *
-The IO-Compress set of modules has been upgraded from version 2.064 to 2.066.
-
-=item *
+L<IO::Socket> has been upgraded from version 1.37 to 1.38.
-L<JSON::PP> has been upgraded from version 2.27203 to 2.27300.
+Document the limitations of the isconnected() method. [perl #123096]
=item *
-The libnet collection of modules has been upgraded from version 1.27 to 3.02.
-
-Support for IPv6 and SSL to Net::FTP, Net::NNTP, Net::POP3 and Net::SMTP.
-
-Improvements in Net::SMTP authentication.
+L<locale> has been upgraded from version 1.04 to 1.05.
=item *
-L<Module::CoreList> has been upgraded from version 5.20140920 to 5.20141020.
-
-Updated to cover the latest releases of Perl.
+L<Module::CoreList> has been upgraded from version 5.20141020 to 5.20141120.
=item *
-L<Opcode> has been upgraded from version 1.28 to 1.29.
+L<overload> has been upgraded from version 1.23 to 1.24.
=item *
-The PathTools module collection has been upgraded from version 3.50 to 3.51.
-
-Slightly faster module loading time.
+L<PerlIO::encoding> has been upgraded from version 0.19 to 0.20.
=item *
-L<perlfaq> has been upgraded from version 5.0150045 to version 5.0150046.
-[perl #123008]
+L<PerlIO::scalar> has been upgraded from version 0.19 to 0.20.
=item *
-L<POSIX> has been upgraded from version 1.43 to 1.45.
-
-POSIX::tmpnam() now produces a deprecation warning. [perl #122005]
+L<POSIX> has been upgraded from version 1.45 to 1.46.
=item *
-L<re> has been upgraded from version 0.26 to 0.27.
+L<re> has been upgraded from version 0.27 to 0.28.
=item *
-L<Socket> has been upgraded from version 2.015 to 2.016.
+L<Test::Harness> has been upgraded from version 3.33 to 3.34.
=item *
-L<Test::Simple> has been upgraded from version 1.001006 to 1.001008.
+L<Test::Simple> has been upgraded from version 1.001008 to 1.301001_075.
=item *
-L<threads::shared> has been upgraded from version 1.46 to 1.47.
+L<Unicode::UCD> has been upgraded from version 0.58 to 0.59.
=item *
-L<warnings> has been upgraded from version 1.26 to 1.28.
+L<warnings> has been upgraded from version 1.28 to 1.29.
=item *
-L<XSLoader> has been upgraded from version 0.17 to 0.18.
-
-Allow XSLoader to load modules from a different namespace.
-[perl #122455]
+L<XSLoader> has been upgraded from version 0.18 to 0.19.
=back
=head2 Changes to Existing Documentation
-=head3 L<perlrecharclass>
+=head3 L<perldata/Identifier parsing>
=over 4
=item *
-Clarifications have been added to L<perlrecharclass/Character Ranges>
-to the effect that Perl guarantees that C<[A-Z]>, C<[a-z]>, C<[0-9]> and
-any subranges thereof in regular expression bracketed character classes
-are guaranteed to match exactly what a naive English speaker would
-expect them to match, even on platforms (such as EBCDIC) where special
-handling is required to accomplish this.
+The syntax of single-character variable names has been brought
+up-to-date and more fully explained.
=back
=head2 New Diagnostics
-=head3 New Errors
+=head3 New Warnings
+
+=over 4
+
+=item *
+
+L<Use of literal non-graphic characters in variable names is deprecated|perldiag/"Use of literal non-graphic characters in variable names is deprecated">
+
+=item *
+
+A new C<locale> warning category has been created, with the following warning
+messages currently in it:
=over 4
=item *
-L<Cannot chr %f|perldiag/"Cannot chr %f">
+L<Locale '%s' may not work well.%s|perldiag/Locale '%s' may not work well.%s>
=item *
-L<Cannot compress %f in pack|perldiag/"Cannot compress %f in pack">
+L<Can't do %s("%s") on non-UTF-8 locale; resolved to "%s".|perldiag/Can't do %s("%s") on non-UTF-8 locale; resolved to "%s".>
+
+=back
=item *
-L<Cannot pack %f with '%c'|perldiag/"Cannot pack %f with '%c'">
+L<Warning: unable to close filehandle %s properly: %s|perldiag/"Warning: unable to close filehandle %s properly: %s">
=item *
-L<Cannot print %f with '%c'|perldiag/"Cannot printf %f with '%c'">
+The following two warnings for C<tr///> used to be skipped if the
+transliteration contained wide characters, but now they occur regardless of
+whether there are wide characters or not:
+
+L<Useless use of E<sol>d modifier in transliteration operator|perldiag/"Useless use of /d modifier in transliteration operator">
+
+L<Replacement list is longer than search list|perldiag/Replacement list is longer than search list>
=back
=item *
-'"my" variable &foo::bar can't be in a package' has been reworded to say
-'subroutine' instead of 'variable'.
+L<Quantifier unexpected on zero-length expression in regex mE<sol>%sE<sol>|perldiag/"Quantifier unexpected on zero-length expression in regex m/%s/">.
+
+This message has had the S<"<-- HERE"> marker removed, as it was always
+placed at the end of the regular expression, regardless of where the
+problem actually occurred. [perl #122680]
+
+=item *
+
+L<Setting $E<sol> to a reference to %s as a form of slurp is deprecated, treating as undef|perldiag/"Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef">
+
+This warning is now a default warning, like other deprecation warnings.
=back
-=head1 Testing
+=head1 Configuration and Compilation
=over 4
=item *
-Some regular expression tests are written in such a way that they will
-run very slowly if certain optimizations break. These tests have been
-moved into new files, F<< t/re/speed.t >> and F<< t/re/speed_thr.t >>,
-and are run with a C<< watchdog() >>.
+F<Configure> with C<-Dmksymlinks> should now be faster. [perl #122002]
=back
-=head1 Platform Support
+=over 4
-=head2 Regained Platforms
+=item *
-IRIX and Tru64 platforms are working again.
-(Some C<make test> failures remain.)
+As well as the gzip and bzip2 tarballs, this release has been made available as an xz utils compressed tarball.
+
+=back
+
+=head1 Platform Support
=head2 Platform-Specific Notes
+=head3 Win32
+
=over 4
-=item EBCDIC
+=item *
+
+In the experimental C<:win32> layer, a crash in C<open> was fixed. Also
+opening C</dev/null>, which works the Win32 Perl's normal C<:unix> layer, was
+implemented for C<:win32>.
+L<[perl #122224]|https://rt.perl.org/Ticket/Display.html?id=122224>
+
+=item *
-Special handling is required on EBCDIC platforms to get C<qr/[i-j]/> to
-match only C<"i"> and C<"j">, since there are 7 characters between the
-code points for C<"i"> and C<"j">. This special handling had only been
-invoked when both ends of the range are literals. Now it is also
-invoked if any of the C<\N{...}> forms for specifying a character by
-name or Unicode code point is used instead of a literal. See
-L<perlrecharclass/Character Ranges>.
+A new makefile option, C<USE_LONG_DOUBLE>, has been added to the Windows
+dmake makefile for gcc builds only. Set this to "define" if you want perl to
+use long doubles to give more accuracy and range for floating point numbers.
=back
=item *
-SVs of type SVt_NV are now bodyless when a build configure and platform allow
-it, specifically C<sizeof(NV) <= sizeof(IV)>. The bodyless trick is the same one
-as for IVs since 5.9.2, but for NVs, unlike IVs, is not guaranteed on all
-platforms and build configurations.
+C<screaminstr> has been removed. Although marked as public API, it is
+undocumented and has no usage in modern perl versions on CPAN Grep. Calling it
+has been fatal since 5.17.0.
=item *
-The C<$DB::single>, C<$DB::signal> and C<$DB::trace> now have set and
-get magic that stores their values as IVs and those IVs are used when
-testing their values in C<pp_dbstate>. This prevents perl from
-recursing infinity if an overloaded object is assigned to any of those
-variables. [perl #122445]
+C<newDEFSVOP>, C<block_start>, C<block_end> and C<intro_my> have been added
+to the API.
=item *
-C<Perl_tmps_grow> which is marked as public API but undocumented has been
-removed from public API. If you use C<EXTEND_MORTAL> macro in your XS code to
-preextend the mortal stack, you are unaffected by this change.
+The internal C<convert> function in F<op.c> has been renamed
+C<op_convert_list> and added to the API.
=item *
-C<cv_name>, which was introduced in 5.21.4, has been changed incompatibly.
-It now has a flags field that allows the caller to specify whether the name
-should be fully qualified. See L<perlapi/cv_name>.
+C<sv_magic> no longer forbids "ext" magic on read-only values. After all,
+perl can't know whether the custom magic will modify the SV or not.
+[perl #123103]
+
+=back
+
+=head1 Selected Bug Fixes
+
+=over 4
=item *
-Internally Perl no longer uses the C<SVs_PADMY> flag. C<SvPADMY()> now
-returns a true value for anything not marked PADTMP. C<SVs_PADMY> is now
-defined as 0.
+fchmod() and futimes() now set C<$!> when they fail due to being
+passed a closed file handle. [perl #122703]
=item *
-The macros SETsv and SETsvUN have been removed. They were no longer used
-in the core since commit 6f1401dc2a, and have not been found present on
-CPAN.
+Perl now comes with a corrected Unicode 7.0 for the erratum issued on
+October 21, 2014 (see L<http://www.unicode.org/errata/#current_errata>),
+dealing with glyph shaping in Arabic.
=item *
-The C<< SvFAKE >> bit (unused on HVs) got informally reserved by
-David Mitchell for future work on vtables.
+op_free() no longer crashes due to a stack overflow when freeing a
+deeply recursive op tree. [perl #108276]
=item *
-The C<sv_catpvn_flags> function accepts C<SV_CATBYTES> and C<SV_CATUTF8>
-flags, which specify whether the appended string is bytes or utf8,
-respectively.
+scalarvoid() would crash due to a stack overflow when processing a
+deeply recursive op tree. [perl #108276]
=item *
-A new opcode class, C<< METHOP >> has been introduced, which holds
-class/method related info needed at runtime to improve performance
-of class/object method calls.
+In Perl 5.20.0, C<$^N> accidentally had the internal UTF8 flag turned off
+if accessed from a code block within a regular expression, effectively
+UTF8-encoding the value. This has been fixed. [perl #123135]
-C<< OP_METHOD >> and C<< OP_METHOD_NAMED >> are moved from being
-C<< UNOP/SVOP >> to being C<< METHOD >>.
+=item *
-=back
+A failed C<semctl> call no longer overwrites existing items on the stack,
+causing C<(semctl(-1,0,0,0))[0]> to give an "uninitialized" warning.
-=head1 Selected Bug Fixes
+=item *
-=over 4
+C<else{foo()}> with no space before C<foo> is now better at assigning the
+right line number to that statement. [perl #122695]
=item *
-Locking and unlocking values via L<Hash::Util> or C<Internals::SvREADONLY>
-no longer has any effect on values that are read-only to begin.
-Previously, unlocking such values could result in crashes, hangs or
-other erratic behaviour.
+Sometimes the assignment in C<@array = split> gets optimised and C<split>
+itself writes directly to the array. This caused a bug, preventing this
+assignment from being used in lvalue context. So
+C<(@a=split//,"foo")=bar()> was an error. (This bug probably goes back to
+Perl 3, when the optimisation was added.) This optimisation, and the bug,
+started to happen in more cases in 5.21.5. It has now been fixed.
+[perl #123057]
=item *
-The internal C<looks_like_number> function (which L<Scalar::Util> provides
-access to) began erroneously to return true for "-e1" in 5.21.4, affecting
-also C<-'-e1'>. This has been fixed.
+When argument lists that fail the checks installed by subroutine
+signatures, the resulting error messages now give the file and line number
+of the caller, not of the called subroutine. [perl #121374]
=item *
-The flip-flop operator (C<..> in scalar context) would return the same
-scalar each time, unless the containing subroutine was called recursively.
-Now it always returns a new scalar. [perl #122829]
+Flip-flop operators (C<..> and C<...> in scalar context) used to maintain
+a separate state for each recursion level (the number of times the
+enclosing sub was called recursively), contrary to the documentation. Now
+each closure has one internal state for each flip-flop. [perl #122829]
=item *
-Some unterminated C<(?(...)...)> constructs in regular expressions would
-either crash or give erroneous error messages. C</(?(1)/> is one such
-example.
+C<use>, C<no>, statement labels, special blocks (C<BEGIN>) and pod are now
+permitted as the first thing in a C<map> or C<grep> block, the block after
+C<print> or C<say> (or other functions) returning a handle, and within
+C<${...}>, C<@{...}>, etc. [perl #122782]
=item *
-C<pack "w", $tied> no longer calls FETCH twice.
+The repetition operator C<x> now propagates lvalue context to its left-hand
+argument when used in contexts like C<foreach>. That allows
+C<for(($#that_array)x2) { ... }> to work as expected if the loop modifies
+$_.
=item *
-List assignments like C<($x, $z) = (1, $y)> now work correctly if $x and $y
-have been aliased by C<foreach>.
+C<(...) x ...> in scalar context used to corrupt the stack if one operand
+were an object with "x" overloading, causing erratic behaviour.
+[perl #121827]
=item *
-Some patterns including code blocks with syntax errors, such as
-C</ (?{(^{})/>, would hang or fail assertions on debugging builds. Now
-they produce errors.
+Assignment to a lexical scalar is often optimised away (as mentioned under
+L</Performance Enhancements>). Various bugs related to this optimisation
+have been fixed. Certain operators on the right-hand side would sometimes
+fail to assign the value at all or assign the wrong value, or would call
+STORE twice or not at all on tied variables. The operators affected were
+C<$foo++>, C<$foo-->, and C<-$foo> under C<use integer>, C<chomp>, C<chr>
+and C<setpgrp>.
=item *
-An assertion failure when parsing C<sort> with debugging enabled has been
-fixed. [perl #122771]
+List assignments were sometimes buggy if the same scalar ended up on both
+sides of the assignment due to used of C<tied>, C<values> or C<each>. The
+result would be the wrong value getting assigned.
=item *
-C<*a = *b; @a = split //, $b[1]> could do a bad read and produce junk
-results.
+C<setpgrp($nonzero)> (with one argument) was accidentally changed in 5.16
+to mean C<setpgrp(0)>. This has been fixed.
=item *
-In C<() = @array = split>, the C<() => at the beginning no longer confuses
-the optimizer, making it assume a limit of 1.
+C<__SUB__> could return the wrong value or even corrupt memory under the
+debugger (the B<-d> switch) and in subs containing C<eval $string>.
=item *
-Fatal warnings no longer prevent the output of syntax errors.
-[perl #122966]
+When C<sub () { $var }> becomes inlinable, it now returns a different
+scalar each time, just as a non-inlinable sub would, though Perl still
+optimises the copy away in cases where it would make no observable
+difference.
=item *
-Fixed a NaN double to long double conversion error on VMS. For quiet NaNs
-(and only on Itanium, not Alpha) negative infinity instead of NaN was
-produced.
+C<my sub f () { $var }> and C<sub () : attr { $var }> are no longer
+eligible for inlining. The former would crash; the latter would just
+throw the attributes away. An exception is made for the little-known
+":method" attribute, which does nothing much.
=item *
-Fixed the issue that caused C<< make distclean >> to leave files behind
-that shouldn't. [perl #122820]
+Inlining of subs with an empty prototype is now more consistent than
+before. Previously, a sub with multiple statements, all but the last
+optimised away, would be inlinable only if it were an anonymous sub
+containing a string C<eval> or C<state> declaration or closing over an
+outer lexical variable (or any anonymous sub under the debugger). Now any
+sub that gets folded to a single constant after statements have been
+optimised away is eligible for inlining. This applies to things like C<sub
+() { jabber() if DEBUG; 42 }>.
+
+Some subroutines with an explicit C<return> were being made inlinable,
+contrary to the documentation, Now C<return> always prevents inlining.
=item *
-AIX now sets the length in C<< getsockopt >> correctly. [perl #120835],
-[rt #91183], [rt #85570].
+On some systems, such as VMS, C<crypt> can return a non-ASCII string. If a
+scalar assigned to had contained a UTF8 string previously, then C<crypt>
+would not turn off the UTF8 flag, thus corrupting the return value. This
+would happen with C<$lexical = crypt ...>.
=item *
-During the pattern optimization phase, we no longer recurse into
-GOSUB/GOSTART when not SCF_DO_SUBSTR. This prevents the optimizer
-to run "forever" and exhaust all memory. [perl #122283]
+C<crypt> no longer calls C<FETCH> twice on a tied first argument.
=item *
-F<< t/op/crypt.t >> now performs SHA-256 algorithm if the default one
-is disabled. [perl #121591]
+An unterminated here-doc on the last line of a quote-like operator
+(C<qq[${ <<END }]>, C</(?{ <<END })/>) no longer causes a double free. It
+started doing so in 5.18.
=item *
-Fixed an off-by-one error when setting the size of shared array.
-[perl #122950]
+Fixed two assertion failures introduced into C<-DPERL_OP_PARENT>
+builds. [perl #108276]
+
+=back
+
+=head1 Known Problems
+
+=over 4
=item *
-Fixed a bug that could cause perl to execute an infinite loop during
-compilation. [perl #122995]
+Starting in 5.21.6, accessing L<perlapi/CvPADLIST> in an XSUB is forbidden.
+CvPADLIST has be reused for a different internal purpose for XSUBs. Guard all
+CvPADLIST expressions with C<CvISXSUB()> if your code doesn't already block
+XSUB CV*s from going through optree CV* expecting code.
+
+=back
+
+=over 4
+
+=item *
+
+Builds on FreeBSD 10.x currently fail when compiling L<POSIX>. A workaround is
+to specify C<-Ui_fenv> when running C<Configure>.
+
+=back
+
+=head1 Errata From Previous Releases
+
+=over 4
+
+=item *
+
+Due to a mistake in the string-copying logic, copying the value of a state
+variable could instead steal the value and undefine the variable. This
+bug, introduced in 5.20, would happen mostly for long strings (1250 chars
+or more), but could happen for any strings under builds with copy-on-write
+disabled. [perl #123029]
+
+This bug was actually fixed in 5.21.5, but it was not until after that
+release that this bug, and the fact that it had been fixed, were
+discovered.
+
+=item *
+
+If a named sub tries to access a scalar declared in an outer anonymous sub,
+the variable is not available, so the named sub gets its own undefined
+scalar. In 5.10, attempts to take a reference to the variable
+(C<\$that_variable>) began returning a reference to a I<copy> of it
+instead. This was accidentally fixed in 5.21.4, but the bug and its fix
+were not noticed till now.
=back
=head1 Acknowledgements
-Perl 5.21.5 represents approximately 4 weeks of development since Perl 5.21.4
-and contains approximately 40,000 lines of changes across 530 files from 33
+Perl 5.21.6 represents approximately 4 weeks of development since Perl 5.21.5
+and contains approximately 60,000 lines of changes across 920 files from 25
authors.
Excluding auto-generated files, documentation and release tools, there were
-approximately 29,000 lines of changes to 390 .pm, .t, .c and .h files.
+approximately 48,000 lines of changes to 630 .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.5:
-
-Aaron Crane, Abigail, Alberto Simões, Andrew Fresh, Chris 'BinGOs' Williams,
-Craig A. Berry, Dagfinn Ilmari Mannsåker, Daniel Dragan, David Mitchell, Doug
-Bell, Ed J, Father Chrysostomos, George Greer, Graham Knop, James E Keenan,
-Jarkko Hietaniemi, Karen Etheridge, Karl Williamson, Leon Timmermans, Lukas
-Mai, Niko Tyni, Peter Martini, Petr Písař, Rafael Garcia-Suarez, Reini Urban,
-Ricardo Signes, Shlomi Fish, Steve Hay, syber, Tony Cook, Vincent Pit, Yves
-Orton, Ævar Arnfjörð Bjarmason.
+improvements that became Perl 5.21.6:
+
+Aaron Crane, Abigail, Andrew Fresh, Andy Dougherty, Brian Fraser, Chad Granum,
+Chris 'BinGOs' Williams, Craig A. Berry, Daniel Dragan, David Mitchell, Doug
+Bell, Father Chrysostomos, Glenn D. Golden, James E Keenan, Jarkko Hietaniemi,
+Jim Cromie, Karen Etheridge, Karl Williamson, Lukas Mai, Ricardo Signes, Shlomi
+Fish, Slaven Rezic, Steve Hay, Tony Cook, Yaroslav Kuzmin.
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
characters and Perl was unable to create a unique filename during
inplace editing with the B<-i> switch. The file was ignored.
+=item Can't do %s("%s") on non-UTF-8 locale; resolved to "%s".
+
+(W locale) You are 1) running under "C<use locale>"; 2) the current
+locale is not a UTF-8 one; 3) you tried to do the designated case-change
+operation on the specified Unicode character; and 4) the result of this
+operation would mix Unicode and locale rules, which likely conflict.
+Mixing of different rule types is forbidden, so the operation was not
+done; instead the result is the indicated value, which is the best
+available that uses entirely Unicode rules. That turns out to almost
+always be the original character, unchanged.
+
+It is generally a bad idea to mix non-UTF-8 locales and Unicode, and
+this issue is one of the reasons why. This warning is raised when
+Unicode rules would normally cause the result of this operation to
+contain a character that is in the range specified by the locale,
+0..255, and hence is subject to the locale's rules, not Unicode's.
+
+If you are using locale purely for its characteristics related to things
+like its numeric and time formatting (and not C<LC_CTYPE>), consider
+using a restricted form of the locale pragma (see L<perllocale/The "use
+locale" pragma>) like "S<C<use locale ':not_characters'>>".
+
+Note that failed case-changing operations done as a result of
+case-insensitive C</i> regular expression matching will show up in this
+warning as having the C<fc> operation (as that is what the regular
+expression engine calls behind the scenes.)
+
=item Can't do waitpid with flags
(F) This machine doesn't have either waitpid() or wait4(), so only
(P) An error peculiar to VMS. Perl thought stdin was a pipe, and tried
to reopen it to accept binary data. Alas, it failed.
+=item Can't represent character for Ox%X on this platform
+
+(F) There is a hard limit to how big a character code point can be due
+to the fundamental properties of UTF-8, especially on EBCDIC
+platforms. The given code point exceeds that. The only work-around is
+to not use such a large code point.
+
=item Can't reset %ENV on this system
(F) You called C<reset('E')> or similar, which tried to reset
=item Can't use %s for loop variable
-(F) Only a simple scalar variable may be used as a loop variable on a
-foreach.
+(P) The parser got confused when trying to parse a C<foreach> loop.
=item Can't use global %s in "%s"
usually indicates a syntax error in dereferencing the constant value.
See L<perlsub/"Constant Functions"> and L<constant>.
+=item Constants from lexical variables potentially modified elsewhere are
+deprecated
+
+(D deprecated) You wrote something like
+
+ my $var;
+ $sub = sub () { $var };
+
+but $var is referenced elsewhere and could be modified after the C<sub>
+expression is evaluated. Either it is explicitly modified elsewhere
+(C<$var = 3>) or it is passed to a subroutine or to an operator like
+C<printf> or C<map>, which may or may not modify the variable.
+
+Traditionally, Perl has captured the value of the variable at that
+point and turned the subroutine into a constant eligible for inlining.
+In those cases where the variable can be modified elsewhere, this
+breaks the behavior of closures, in which the subroutine captures
+the variable itself, rather than its value, so future changes to the
+variable are reflected in the subroutine's return value.
+
+This usage is deprecated, because the behavior is likely to change
+in a future version of Perl.
+
+If you intended for the subroutine to be eligible for inlining, then
+make sure the variable is not referenced elsewhere, possibly by
+copying it:
+
+ my $var2 = $var;
+ $sub = sub () { $var2 };
+
+If you do want this subroutine to be a closure that reflects future
+changes to the variable that it closes over, add an explicit C<return>:
+
+ my $var;
+ $sub = sub () { return $var };
+
=item Constant subroutine %s redefined
(W redefine)(S) You redefined a subroutine which had previously
S<<-- HERE> in m/%s/
(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.
+zero-length sequence. When such an escape is used in a character
+class its behavior is not well defined. Check that the correct
+escape has been used, and the correct charname handler is in scope.
=item Illegal binary digit %s
The S<<-- HERE> shows whereabouts in the regular expression the
escape was discovered.
+=item %s: Invalid handshake key got %p needed %p, binaries are mismatched
+
+(P) A dynamic loading library C<.so> or C<.dll> was being loaded into the
+process that was built against a different build of perl than the
+said library was compiled against. Reinstalling the XS module will
+likely fix this error.
+
=item Invalid hexadecimal number in \N{U+...}
=item Invalid hexadecimal number in \N{U+...} in regex; marked by
form of C<open> does not support pipes, such as C<open($pipe, '|-', @args)>.
Use the two-argument C<open($pipe, '|prog arg1 arg2...')> form instead.
+=item Locale '%s' may not work well.%s
+
+(W locale) The named locale that Perl is now trying to use is not fully
+compatible with Perl. The second C<%s> gives a reason.
+
+By far the most common reason is that the locale has characters in it
+that are represented by more than one byte. The only such locales that
+Perl can handle are the UTF-8 locales. Most likely the specified locale
+is a non-UTF-8 one for an East Asian language such as Chinese or
+Japanese. If the locale is a superset of ASCII, the ASCII portion of it
+may work in Perl. Read on for problems when it isn't a superset of
+ASCII.
+
+Some essentially obsolete locales that aren't supersets of ASCII, mainly
+those in ISO 646 or other 7-bit locales, such as ASMO 449, can also have
+problems, depending on what portions of the ASCII character set get
+changed by the locale and are also used by the program.
+The warning message lists the determinable conflicting characters.
+
=item localtime(%f) failed
(W overflow) You called C<localtime> with a number that it could not handle:
imagine. The sole exceptions to this are that zero padding will
take place when going past the end of the string when either
C<sysread()>ing a file, or when seeking past the end of a scalar opened
-for I/O (in anticipation of future reads and to imitate the behaviour
+for I/O (in anticipation of future reads and to imitate the behavior
with real files).
=item %s() on unopened %s
command-line switch. (This output goes to STDOUT unless you've
redirected it with select().)
+=item Perl API version %s of %s does not match %s
+
+(F) The XS module in question was compiled against a different incompatible
+version of Perl than the one that has loaded the XS module.
+
=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/
parentheses is useless, since it will be replaced by the prototype
from the attribute before it's ever used.
-=item \p{} uses Unicode rules, not locale rules
-
-(W) You compiled a regular expression that contained a Unicode property
-match (C<\p> or C<\P>), but the regular expression is also being told to
-use the run-time locale, not Unicode. Instead, use a POSIX character
-class, which should know about the locale's rules.
-(See L<perlrecharclass/POSIX Character Classes>.)
-
-Even if the run-time locale is ISO 8859-1 (Latin1), which is a subset of
-Unicode, some properties will give results that are not valid for that
-subset.
-
-Here are a couple of examples to help you see what's going on. If the
-locale is ISO 8859-7, the character at code point 0xD7 is the "GREEK
-CAPITAL LETTER CHI". But in Unicode that code point means the
-"MULTIPLICATION SIGN" instead, and C<\p> always uses the Unicode
-meaning. That means that C<\p{Alpha}> won't match, but C<[[:alpha:]]>
-should. Only in the Latin1 locale are all the characters in the same
-positions as they are in Unicode. But, even here, some properties give
-incorrect results. An example is C<\p{Changes_When_Uppercased}> which
-is true for "LATIN SMALL LETTER Y WITH DIAERESIS", but since the upper
-case of that character is not in Latin1, in that locale it doesn't
-change when upper cased.
-
=item push on reference is experimental
(S experimental::autoderef) C<push> with a scalar argument is experimental
(W regexp) Minima should be less than or equal to maxima. If you really
want your regexp to match something 0 times, just put {0}.
-=item Quantifier unexpected on zero-length expression in regex; marked by <--
-HERE in m/%s/
+=item Quantifier unexpected on zero-length expression in regex m/%s/
(W regexp) You applied a regular expression quantifier in a place where
it makes no sense, such as on a zero-width assertion. Try putting the
"abc" provided that it is followed by three repetitions of "xyz" is
C</abc(?=(?:xyz){3})/>, not C</abc(?=xyz){3}/>.
-The <-- HERE shows whereabouts in the regular expression the problem was
-discovered.
-
=item Range iterator outside integer range
(F) One (or both) of the numeric arguments to the range operator ".."
(W closed) The socket you're sending to got itself closed sometime
before now. Check your control flow.
+=item Sequence "\c{" invalid
+
+(F) These three characters may not appear in sequence in a
+double-quotish context. This message is raised only on non-ASCII
+platforms (a different error message is output on ASCII ones). If you
+were intending to specify a control character with this sequence, you'll
+have to use a different way to specify it.
+
=item Sequence (? incomplete in regex; marked by S<<-- HERE> in m/%s/
(F) A regular expression ended with an incomplete extension (?. The
=item Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef
-(W deprecated) You assigned a reference to a scalar to C<$/> where the
+(D deprecated) You assigned a reference to a scalar to C<$/> where the
referenced item is not a positive integer. In older perls this B<appeared>
to work the same as setting it to C<undef> but was in fact internally
different, less efficient and with very bad luck could have resulted in
=item Use of literal control characters in variable names is deprecated
-(D deprecated) Using literal control characters in the source to refer
-to the ^FOO variables, like C<$^X> and C<${^GLOBAL_PHASE}> is now
-deprecated. This only affects code like C<$\cT>, where \cT is a control in
-the source code: C<${"\cT"}> and C<$^T> remain valid.
+=item Use of literal non-graphic characters in variable names is deprecated
+
+(D deprecated) Using literal non-graphic (including control)
+characters in the source to refer to the ^FOO variables, like C<$^X> and
+C<${^GLOBAL_PHASE}> is now deprecated. (We use C<^X> and C<^G> here for
+legibility. They actually represent the non-printable control
+characters, code points 0x18 and 0x07, respectively; C<^A> would mean
+the control character whose code point is 0x01.) This only affects
+code like C<$\cT>, where C<\cT> is a control in the source code; C<${"\cT"}> and
+C<$^T> remain valid. Things that are non-controls and also not graphic
+are NO-BREAK SPACE and SOFT HYPHEN, which were previously only allowed
+for historical reasons.
=item Use of -l on filehandle%s
=item Using !~ with %s doesn't make sense
(F) Using the C<!~> operator with C<s///r>, C<tr///r> or C<y///r> is
-currently reserved for future use, as the exact behaviour has not
+currently reserved for future use, as the exact behavior has not
been decided. (Simply returning the boolean opposite of the
modified string is usually not particularly useful.)
the close(). This usually indicates your file system ran out of disk
space.
+=item Warning: unable to close filehandle properly: %s
+
+=item Warning: unable to close filehandle %s properly: %s
+
+(S io) An error occurred when Perl implicitly closed a filehandle. This
+usually indicates your file system ran out of disk space.
+
=item Warning: Use of "%s" without parentheses is ambiguous
(S ambiguous) You wrote a unary operator followed by something that
SEPARATOR> concatenated with I<X> for all I<X>.
The outlier C<\c?> on ASCII, which yields a non-C0 control C<DEL>,
yields the outlier control C<APC> on EBCDIC, the one that isn't in the
-block of contiguous controls.
+block of contiguous controls. Note that a subtlety of this is that
+C<\c?> on ASCII platforms is an ASCII character, while it isn't
+equivalent to any ASCII character in EBCDIC platforms.
chr ord 8859-1 0037 1047 && POSIX-BC
-----------------------------------------------------------------------
rules for the remaining code points (this last can only happen if
the UTF8 flag is also set). See L<perllocale>.
-Starting in v5.20, Perl wil use full Unicode rules if the locale is
+Starting in v5.20, Perl uses full Unicode rules if the locale is
UTF-8. Otherwise, there is a deficiency in this scheme, which is that
case changes that cross the 255/256
boundary are not well-defined. For example, the lower case of LATIN CAPITAL
itself, because 0xDF may not be LATIN SMALL LETTER SHARP S in the
current locale, and Perl has no way of knowing if that character even
exists in the locale, much less what code point it is. Perl returns
-the input character unchanged, for all instances (and there aren't
-many) where the 255/256 boundary would otherwise be crossed.
+a result that is above 255 (almost always the input character unchanged,
+for all instances (and there aren't many) where the 255/256 boundary
+would otherwise be crossed; and starting in v5.22, it raises a
+L<locale|perldiag/Can't do %s("%s") on non-UTF-8 locale; resolved to "%s".> warning.
=item Otherwise, If EXPR has the UTF8 flag set:
doesn't it won't realize something is wrong until it gets to the C<}> and
encounters the missing (or unexpected) comma. The syntax error will be
reported close to the C<}>, but you'll need to change something near the C<{>
-such as using a unary C<+> to give Perl some help:
+such as using a unary C<+> or semicolon to give Perl some help:
%hash = map { "\L$_" => 1 } @array # perl guesses EXPR. wrong
%hash = map { +"\L$_" => 1 } @array # perl guesses BLOCK. right
- %hash = map { ("\L$_" => 1) } @array # this also works
- %hash = map { lc($_) => 1 } @array # as does this.
+ %hash = map {; "\L$_" => 1 } @array # this also works
+ %hash = map { ("\L$_" => 1) } @array # as does this
+ %hash = map { lc($_) => 1 } @array # and this.
%hash = map +( lc($_) => 1 ), @array # this is EXPR and works!
%hash = map ( lc($_), 1 ), @array # evaluates to (1, @array)
0x56 0x78 0x12 0x34
0x34 0x12 0x78 0x56
+These are called mid-endian, middle-endian, mixed-endian, or just weird.
+
You can determine your system endianness with this incantation:
printf("%#02x ", $_) for unpack("W*", pack L=>0x12345678);
$ perl -V:byteorder
Byteorders C<"1234"> and C<"12345678"> are little-endian; C<"4321">
-and C<"87654321"> are big-endian.
+and C<"87654321"> are big-endian. Systems with multiarchitecture binaries
+will have C<"ffff">, signifying that static information doesn't work,
+one must use runtime probing.
For portably packed integers, either use the formats C<n>, C<N>, C<v>,
and C<V> or else use the C<< > >> and C<< < >> modifiers described
=item *
+Also floating point numbers have endianness. Usually (but not always)
+this agrees with the integer endianness. Even though most platforms
+these days use the IEEE 754 binary format, there are differences,
+especially if the long doubles are involved. You can see the
+C<Config> variables C<doublekind> and C<longdblkind> (also C<doublesize>,
+C<longdblsize>): the "kind" values are enums, unlike C<byteorder>.
+
+Portability-wise the best option is probably to keep to the IEEE 754
+64-bit doubles, and of agreed-upon endianness. Another possibility
+is the C<"%a">) format of C<printf>.
+
+=item *
+
Starting with Perl 5.10.0, integer and floating-point formats, along with
the C<p> and C<P> formats and C<()> groups, may all be followed by the
C<< > >> or C<< < >> endianness modifiers to respectively enforce big-
assumes additional C<""> arguments. If TEMPLATE requires fewer arguments
than given, extra arguments are ignored.
+=item *
+
+Attempting to pack the special floating point values C<Inf> and C<NaN>
+(infinity, also in negative, and not-a-number) into packed integer values
+(like C<"L">) is a fatal error. The reason for this is that there simply
+isn't any sensible mapping for these special values into integers.
+
=back
Examples:
Note that a return value of C<-1> could mean that child processes are
being automatically reaped, as described in L<perlipc>.
-If you use wait in your handler for $SIG{CHLD} it may accidentally for the
-child created by qx() or system(). See L<perlipc> for details.
+If you use C<wait> in your handler for $SIG{CHLD}, it may accidentally wait
+
for the child created by qx() or system(). See L<perlipc> for details.
Portability issues: L<perlport/wait>.
Now you should create a patch file for all your local changes:
- % git format-patch -M origin..
+ % git format-patch -M blead..
0001-Rename-Leon-Brocard-to-Orange-Brocard.patch
Or for a lot of changes, e.g. from a topic branch:
- % git format-patch --stdout -M origin.. > topic-branch-changes.patch
+ % git format-patch --stdout -M blead.. > topic-branch-changes.patch
You should now send an email to
L<perlbug@perl.org|mailto:perlbug@perl.org> with a description of your
L<perl5-porters@perl.org|mailto:perl5-porters@perl.org> directly if the
patch is not ready to be applied, but intended for discussion.
-See the next section for how to configure and use git to send these
-emails for you.
+Please do not use git-send-email(1) to send your patch. See L<Sending
+patch emails|/Sending patch emails> for more information.
If you want to delete your temporary branch, you may do so with:
{
PerlIOl * next; /* Lower layer */
PerlIO_funcs * tab; /* Functions for this layer */
- IV flags; /* Various flags for state */
+ U32 flags; /* Various flags for state */
};
A C<PerlIOl *> is a pointer to the struct, and the I<application>
=item *
-The current locale is also used when going outside of Perl with
+The current locale is used when going outside of Perl with
operations like L<system()|perlfunc/system LIST> or
L<qxE<sol>E<sol>|perlop/qxE<sol>STRINGE<sol>>, if those operations are
locale-sensitive.
# restore the old locale
setlocale(LC_CTYPE, $old_locale);
+This simultaneously affects all threads of the program, so it may be
+problematic to use locales in threaded applications except where there
+is a single locale applicable to all threads.
+
The first argument of C<setlocale()> gives the B<category>, the second the
B<locale>. The category tells in what aspect of data processing you
want to apply locale-specific rules. Category names are discussed in
You can test out changing these variables temporarily, and if the
new settings seem to help, put those settings into your shell startup
-files. Consult your local documentation for the exact details. For in
+files. Consult your local documentation for the exact details. For
Bourne-like shells (B<sh>, B<ksh>, B<bash>, B<zsh>):
LC_ALL=en_US.ISO8859-1
setenv LC_ALL en_US.ISO8859-1
-or if you have the "env" application you can do in any shell
+or if you have the "env" application you can do (in any shell)
env LC_ALL=en_US.ISO8859-1 perl ...
The C<LC_CTYPE> locale also provides the map used in transliterating
characters between lower and uppercase. This affects the case-mapping
-functions--C<fc()>, C<lc()>, C<lcfirst()>, C<uc()>, and C<ucfirst()>; case-mapping
+functions--C<fc()>, C<lc()>, C<lcfirst()>, C<uc()>, and C<ucfirst()>;
+case-mapping
interpolation with C<\F>, C<\l>, C<\L>, C<\u>, or C<\U> in double-quoted
strings and C<s///> substitutions; and case-independent regular expression
pattern matching using the C<i> modifier.
Finally, C<LC_CTYPE> affects the (deprecated) POSIX character-class test
functions--C<POSIX::isalpha()>, C<POSIX::islower()>, and so on. For
-example, if you move from the "C" locale to a 7-bit Scandinavian one,
-you may find--possibly to your surprise--that "|" moves from the
+example, if you move from the "C" locale to a 7-bit ISO 646 one,
+you may find--possibly to your surprise--that C<"|"> moves from the
C<POSIX::ispunct()> class to C<POSIX::isalpha()>.
Unfortunately, this creates big problems for regular expressions. "|" still
-means alternation even though it matches C<\w>.
+means alternation even though it matches C<\w>. Starting in v5.22, a
+warning will be raised when such a locale is switched into. More
+details are given several paragraphs further down.
Starting in v5.20, Perl supports UTF-8 locales for C<LC_CTYPE>, but
otherwise Perl only supports single-byte locales, such as the ISO 8859
series. This means that wide character locales, for example for Asian
-languages, are not supported. The UTF-8 locale support is actually a
+languages, are not well-supported. (If the platform has the capability
+for Perl to detect such a locale, starting in Perl v5.22,
+L<Perl will warn, default enabled|warnings/Category Hierarchy>,
+using the C<locale> warning category, whenever such a locale is switched
+into.) The UTF-8 locale support is actually a
superset of POSIX locales, because it is really full Unicode behavior
as if no locale were in effect at all (except for tainting; see
L</SECURITY>). POSIX locales, even UTF-8 ones,
used as a workaround for this (see L</Unicode and UTF-8>).
Note that there are quite a few things that are unaffected by the
-current locale. All the escape sequences for particular characters,
+current locale. Any literal character is the native character for the
+given platform. Hence 'A' means the character at code point 65 on ASCII
+platforms, and 193 on EBCDIC. That may or may not be an 'A' in the
+current locale, if that locale even has an 'A'.
+Similarly, all the escape sequences for particular characters,
C<\n> for example, always mean the platform's native one. This means,
for example, that C<\N> in regular expressions (every character
but new-line) works on the platform character set.
+Starting in v5.22, Perl will by default warn when switching into a
+locale that redefines any ASCII printable character (plus C<\t> and
+C<\n>) into a different class than expected. This is unlikely to
+happen on modern locales, but can happen with the ISO 646 and other
+7-bit locales that are essentially obsolete. Things may still work,
+depending on what features of Perl are used by the program. For
+example, in the example from above where C<"|"> becomes a C<\w>, and
+there are no regular expressions where this matters, the program may
+still work properly. The warning lists all the characters that
+it can determine could be adversely affected.
+
B<Note:> A broken or malicious C<LC_CTYPE> locale definition may result
in clearly ineligible characters being considered to be alphanumeric by
your application. For strict matching of (mundane) ASCII letters and
Pre-v5.12, it was somewhat haphazard; in v5.12 it was applied fairly
consistently to regular expression matching except for bracketed
character classes; in v5.14 it was extended to all regex matches; and in
-v5.16 to the casing operations such as C<"\L"> and C<uc()>. For
+v5.16 to the casing operations such as C<\L> and C<uc()>. For
collation, in all releases, the system's C<strxfrm()> function is called,
and whatever it does is what you get.
=head1 DESCRIPTION
In Perl, the operator determines what operation is performed,
-independent of the type of the operands. For example C<$a + $b>
-is always a numeric addition, and if C<$a> or C<$b> do not contain
+independent of the type of the operands. For example C<$x + $y>
+is always a numeric addition, and if C<$x> or C<$y> do not contain
numbers, an attempt is made to convert them to numbers first.
This is in contrast to many other dynamic languages, where the
operation is determined by the type of the first argument. It also
means that Perl has two versions of some operators, one for numeric
-and one for string comparison. For example C<$a == $b> compares
-two numbers for equality, and C<$a eq $b> compares two strings.
+and one for string comparison. For example C<$x == $y> compares
+two numbers for equality, and C<$x eq $y> compares two strings.
There are a few exceptions though: C<x> can be either string
repetition or list repetition, depending on the type of the left
Binary "%" is the modulo operator, which computes the division
remainder of its first argument with respect to its second argument.
Given integer
-operands C<$a> and C<$b>: If C<$b> is positive, then C<$a % $b> is
-C<$a> minus the largest multiple of C<$b> less than or equal to
-C<$a>. If C<$b> is negative, then C<$a % $b> is C<$a> minus the
-smallest multiple of C<$b> that is not less than C<$a> (that is, the
+operands C<$m> and C<$n>: If C<$n> is positive, then C<$m % $n> is
+C<$m> minus the largest multiple of C<$n> less than or equal to
+C<$m>. If C<$n> is negative, then C<$m % $n> is C<$m> minus the
+smallest multiple of C<$n> that is not less than C<$m> (that is, the
result will be less than or equal to zero). If the operands
-C<$a> and C<$b> are floating point values and the absolute value of
-C<$b> (that is C<abs($b)>) is less than C<(UV_MAX + 1)>, only
-the integer portion of C<$a> and C<$b> will be used in the operation
+C<$m> and C<$n> are floating point values and the absolute value of
+C<$n> (that is C<abs($n)>) is less than C<(UV_MAX + 1)>, only
+the integer portion of C<$m> and C<$n> will be used in the operation
(Note: here C<UV_MAX> means the maximum of the unsigned integer type).
-If the absolute value of the right operand (C<abs($b)>) is greater than
+If the absolute value of the right operand (C<abs($n)>) is greater than
or equal to C<(UV_MAX + 1)>, "%" computes the floating-point remainder
-C<$r> in the equation C<($r = $a - $i*$b)> where C<$i> is a certain
+C<$r> in the equation C<($r = $m - $i*$n)> where C<$i> is a certain
integer that makes C<$r> have the same sign as the right operand
-C<$b> (B<not> as the left operand C<$a> like C function C<fmod()>)
-and the absolute value less than that of C<$b>.
+C<$n> (B<not> as the left operand C<$m> like C function C<fmod()>)
+and the absolute value less than that of C<$n>.
Note that when C<use integer> is in scope, "%" gives you direct access
to the modulo operator as implemented by your C compiler. This
operator is not as well defined for negative operands, but it will
support NaNs then NaN is just a string with numeric value 0.
X<< <=> >> X<spaceship>
- $ perl -le '$a = "NaN"; print "No NaN support here" if $a == $a'
- $ perl -le '$a = "NaN"; print "NaN support here" if $a != $a'
+ $ perl -le '$x = "NaN"; print "No NaN support here" if $x == $x'
+ $ perl -le '$x = "NaN"; print "NaN support here" if $x != $x'
-(Note that the L<bigint>, L<bigrat>, and L<bignum> pragmas all
+(Note that the L<bigint>, L<bigrat>, and L<bignum> pragmas all
support "NaN".)
Binary "eq" returns true if the left argument is stringwise equal to
the ternary-operator form can be used as a lvalue, while C<< EXPR1 // EXPR2 >>
cannot). This is very useful for
providing default values for variables. If you actually want to test if
-at least one of C<$a> and C<$b> is defined, use C<defined($a // $b)>.
+at least one of C<$x> and C<$y> is defined, use C<defined($x // $y)>.
The C<||>, C<//> and C<&&> operators return the last value evaluated
(unlike C's C<||> and C<&&>, which return 0 or 1). Thus, a reasonably
Scalar or list context propagates downward into the 2nd
or 3rd argument, whichever is selected.
- $a = $ok ? $b : $c; # get a scalar
- @a = $ok ? @b : @c; # get an array
- $a = $ok ? @b : @c; # oops, that's just a count!
+ $x = $ok ? $y : $z; # get a scalar
+ @x = $ok ? @y : @z; # get an array
+ $x = $ok ? @y : @z; # oops, that's just a count!
The operator may be assigned to if both the 2nd and 3rd arguments are
legal lvalues (meaning that you can assign to them):
- ($a_or_b ? $a : $b) = $c;
+ ($x_or_y ? $x : $y) = $z;
Because this operator produces an assignable result, using assignments
without parentheses will get you in trouble. For example, this:
- $a % 2 ? $a += 10 : $a += 2
+ $x % 2 ? $x += 10 : $x += 2
Really means this:
- (($a % 2) ? ($a += 10) : $a) += 2
+ (($x % 2) ? ($x += 10) : $x) += 2
Rather than this:
- ($a % 2) ? ($a += 10) : ($a += 2)
+ ($x % 2) ? ($x += 10) : ($x += 2)
That should probably be written more simply as:
- $a += ($a % 2) ? 10 : 2;
+ $x += ($x % 2) ? 10 : 2;
=head2 Assignment Operators
X<assignment> X<operator, assignment> X<=> X<**=> X<+=> X<*=> X<&=>
Assignment operators work as in C. That is,
- $a += 2;
+ $x += 2;
is equivalent to
- $a = $a + 2;
+ $x = $x + 2;
although without duplicating any side effects that dereferencing the lvalue
might trigger, such as from tie(). Other assignment operators work similarly.
Likewise,
- ($a += 2) *= 3;
+ ($x += 2) *= 3;
is equivalent to
- $a += 2;
- $a *= 3;
+ $x += 2;
+ $x *= 3;
Similarly, a list assignment in list context produces the list of
lvalues assigned to, and a list assignment in scalar context returns
be careful to avoid using it as replacement for the C<||> operator.
It usually works out better for flow control than in assignments:
- $a = $b or $c; # bug: this is wrong
- ($a = $b) or $c; # really means this
- $a = $b || $c; # better written this way
+ $x = $y or $z; # bug: this is wrong
+ ($x = $y) or $z; # really means this
+ $x = $y || $z; # better written this way
However, when it's a list-context assignment and you're trying to use
C<||> for control flow, you probably need "or" so that the assignment
Note, however, that this does not always work for quoting Perl code:
- $s = q{ if($a eq "}") ... }; # WRONG
+ $s = q{ if($x eq "}") ... }; # WRONG
is a syntax error. The C<Text::Balanced> module (standard as of v5.8,
and from CPAN before then) is able to do this properly.
Note that it's possible to confuse Perl into thinking C<//> (the empty
regex) is really C<//> (the defined-or operator). Perl is usually pretty
good about this, but some pathological cases might trigger this, such as
-C<$
a///> (is that C<($a) / (//)> or C<$a // />?) and C<print $fh //>
+C<$
x///> (is that C<($x) / (//)> or C<$x // />?) and C<print $fh //>
(C<print $fh(//> or C<print($fh //>?). In all of these examples, Perl
will assume you meant defined-or. If you meant the empty regex, just
use parentheses or spaces to disambiguate, or even prefix the empty
s/^=(\w+)/pod($1)/ge; # use function call
$_ = 'abc123xyz';
- $a = s/abc/def/r; # $a is 'def123xyz' and
+ $x = s/abc/def/r; # $x is 'def123xyz' and
# $_ remains 'abc123xyz'.
# expand variables in $_, but dynamics only, using
Note also that the interpolation code needs to make a decision on
where the interpolated scalar ends. For instance, whether
-C<< "a $b -> {c}" >> really means:
+C<< "a $x -> {c}" >> really means:
- "a " . $b . " -> {c}";
+ "a " . $x . " -> {c}";
or:
- "a " . $b -> {c};
+ "a " . $x -> {c};
Most of the time, the longest possible text that does not include
spaces between components and which contains matching braces or
Or with rationals:
- use 5.010;
- use bigrat;
- $a = 3/22;
- $b = 4/6;
- say "a/b is ", $a/$b;
- say "a*b is ", $a*$b;
- a/b is 9/44
- a*b is 1/11
+ use 5.010;
+ use bigrat;
+ $x = 3/22;
+ $y = 4/6;
+ say "x/y is ", $x/$y;
+ say "x*y is ", $x*$y;
+ x/y is 9/44
+ x*y is 1/11
Several modules let you calculate with (bound only by memory and CPU time)
unlimited or fixed precision. There
platforms, may not be available in the same location, might accept
different arguments, can behave differently, and often present their
results in a platform-dependent way. Thus, you should seldom depend
-on them to produce consistent results. (Then again, if you're calling
+on them to produce consistent results. (Then again, if you're calling
I<netstat -a>, you probably don't expect it to run on both Unix and CP/M.)
One especially common bit of Perl code is opening a pipe to B<sendmail>:
- open(MAIL, '|/usr/lib/sendmail -t')
+ open(MAIL, '|/usr/lib/sendmail -t')
or die "cannot fork sendmail: $!";
This is fine for systems programming when sendmail is known to be
platforms; two, to provide users with information about whether
a given module works on a given platform.
-Also see:
+Also see:
=over 4
BSD/OS bsdos i386-bsdos
Darwin darwin darwin
DYNIX/ptx dynixptx i386-dynixptx
- FreeBSD freebsd freebsd-i386
+ FreeBSD freebsd freebsd-i386
Haiku haiku BePC-haiku
Linux linux arm-linux
Linux linux armv5tel-linux
OS $^O $Config{archname} ID Version
--------------------------------------------------------
- MS-DOS dos ?
- PC-DOS dos ?
+ MS-DOS dos ?
+ PC-DOS dos ?
OS/2 os2 ?
Windows 3.1 ? ? 0 3 01
Windows 95 MSWin32 MSWin32-x86 1 4 00
Windows 7 MSWin32 MSWin32-x64 2 6 01
Windows 2008 MSWin32 MSWin32-x86 2 6 01
Windows 2008 MSWin32 MSWin32-x64 2 6 01
- Windows CE MSWin32 ? 3
+ Windows CE MSWin32 ? 3
Cygwin cygwin cygwin
The various MSWin32 Perl's can distinguish the OS they are running on
-via the value of the fifth element of the list returned from
+via the value of the fifth element of the list returned from
Win32::GetOSVersion(). For example:
if ($^O eq 'MSWin32') {
=item *
Build instructions for Win32 in L<perlwin32>, or under the Cygnus environment
-in L<perlcygwin>.
+in L<perlcygwin>.
=item *
=item *
-The Cygwin environment for Win32; F<README.cygwin> (installed
+The Cygwin environment for Win32; F<README.cygwin> (installed
as L<perlcygwin>), L<http://www.cygwin.com/>
=item *
see if VMS is in a case sensitive mode.
What C<\n> represents depends on the type of file opened. It usually
-represents C<\012> but it could also be C<\015>, C<\012>, C<\015\012>,
-C<\000>, C<\040>, or nothing depending on the file organization and
-record format. The VMS::Stdio module provides access to the
+represents C<\012> but it could also be C<\015>, C<\012>, C<\015\012>,
+C<\000>, C<\040>, or nothing depending on the file organization and
+record format. The VMS::Stdio module provides access to the
special fopen() requirements of files with unusual attributes on VMS.
TCP/IP stacks are optional on VMS, so socket routines might not be
the BS200 POSIX-BC system (BS2000 is supported in perl 5.6 and greater).
See L<perlos390> for details. Note that for OS/400 there is also a port of
Perl 5.8.1/5.10.0 or later to the PASE which is ASCII-based (as opposed to
-ILE which is EBCDIC-based), see L<perlos400>.
+ILE which is EBCDIC-based), see L<perlos400>.
As of R2.5 of USS for OS/390 and Version 2.3 of VM/ESA these Unix
sub-systems do not support the C<#!> shebang trick for script invocation.
=head2 Acorn RISC OS
Because Acorns use ASCII with newlines (C<\n>) in text files as C<\012> like
-Unix, and because Unix filename emulation is turned on by default,
+Unix, and because Unix filename emulation is turned on by default,
most simple scripts will probably work "out of the box". The native
filesystem is modular, and individual filesystems are free to be
case-sensitive or insensitive, and are usually case-preserving. Some
directory without affecting its parent (and everyone else for that
matter).
-Because native operating system filehandles are global and are currently
+Because native operating system filehandles are global and are currently
allocated down from 255, with 0 being a reserved value, the Unix emulation
library emulates Unix filehandles. Consequently, you can't rely on
passing C<STDIN>, C<STDOUT>, or C<STDERR> to your children.
results for C<atan2()> may vary depending on any combination of the above.
Perl attempts to conform to the Open Group/IEEE standards for the results
returned from C<atan2()>, but cannot force the issue if the system Perl is
-run on does not allow it. (Tru64, HP-UX 10.20)
+run on does not allow it. (Tru64, HP-UX 10.20)
-The current version of the standards for C<atan2()> is available at
+The current version of the standards for C<atan2()> is available at
L<http://www.opengroup.org/onlinepubs/009695399/functions/atan2.html>.
=item binmode
the C library _POSIX_EXIT macro so that it can be decoded by other
programs, particularly ones written in C, like the GNV package. (VMS)
-C<exit()> resets file pointers, which is a problem when called
-from a child process (created by C<fork()>) in C<BEGIN>.
+C<exit()> resets file pointers, which is a problem when called
+from a child process (created by C<fork()>) in C<BEGIN>.
A workaround is to use C<POSIX::_exit>. (Solaris)
exit unless $Config{archname} =~ /\bsolaris\b/;
open to C<|-> and C<-|> are unsupported. (Win32, S<RISC OS>)
+List-form pipe opens may fall back to the shell if the first spawn()
+fails. (Win32)
+
Opening a process does not automatically flush output handles on some
platforms. (SunOS, Solaris, HP-UX)
The return value is POSIX-like (shifted up by 8 bits), which only allows
room for a made-up value derived from the severity bits of the native
-32-bit condition code (unless overridden by C<use vmsish 'status'>).
+32-bit condition code (unless overridden by C<use vmsish 'status'>).
If the native condition code is one that has a POSIX value encoded, the
POSIX value will be decoded to extract the expected exit value.
For more details see L<perlvms/$?>. (VMS)
=back
-=head1 EOL Platforms
+=head1 EOL Platforms
=head2 (Perl 5.20)
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
+ 'ss' =~ /\A[\0-\x{ff}]\z/ui # Doesn't match
+ 'ss' =~ /\A[\0-\N{LATIN SMALL LETTER SHARP S}]\z/ui # No match
+ 'ss' =~ /\A[\xDF-\xDF]\z/ui # Matches on ASCII platforms, since
# \XDF is LATIN SMALL LETTER SHARP S,
# and the range is just a single
# element
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
+instance where a bracketed class can match multiple 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
and
C<\x>
are also special and have the same meanings as they do outside a
-bracketed character class. (However, inside a bracketed character
-class, if C<\N{I<NAME>}> expands to a sequence of characters, only the first
-one in the sequence is used, with a warning.)
+bracketed character class.
Also, a backslash followed by two or three octal digits is considered an octal
number.
return($x * __SUB__->( $x - 1 ) );
};
-The behaviour of C<__SUB__> within a regex code block (such as C</(?{...})/>)
+The behavior of C<__SUB__> within a regex code block (such as C</(?{...})/>)
is subject to change.
Subroutines whose names are in all upper case are reserved to the Perl
B<WARNING>: Localization of tied arrays and hashes does not currently
work as described.
This will be fixed in a future release of Perl; in the meantime, avoid
-code that relies on any particular behaviour of localising tied arrays
+code that relies on any particular behavior of localising tied arrays
or hashes (localising individual elements is still okay).
See L<perl58delta/"Localising Tied Arrays and Hashes Is Broken"> for more
details.
sub N () { int(OPT_BAZ) / 3 }
sub FOO_SET () { 1 if FLAG_MASK & FLAG_FOO }
+ sub FOO_SET2 () { if (FLAG_MASK & FLAG_FOO) { 1 } }
-Be aware that these will not be inlined; as they contain inner scopes,
-the constant folding doesn't reduce them to a single constant:
-
- sub foo_set () { if (FLAG_MASK & FLAG_FOO) { 1 } }
+(Be aware that the last example was not always inlined in Perl 5.20 and
+earlier, which did not behave consistently with subroutines containing
+inner scopes.) You can countermand inlining by using an explicit
+C<return>:
sub baz_val () {
if (OPT_BAZ) {
return 42;
}
}
+ sub bonk_val () { return 12345 }
As alluded to earlier you can also declare inlined subs dynamically at
BEGIN time if their body consists of a lexically-scoped scalar which
}
print RT_79908(); # prints 79907
+As of Perl 5.22, this buggy behavior, while preserved for backward
+compatibility, is detected and emits a deprecation warning. If you want
+the subroutine to be inlined (with no warning), make sure the variable is
+not used in a context where it could be modified aside from where it is
+declared.
+
+ # Fine, no warning
+ BEGIN {
+ my $x = 54321;
+ *INLINED = sub () { $x };
+ }
+ # Warns. Future Perl versions will stop inlining it.
+ BEGIN {
+ my $x;
+ $x = 54321;
+ *ALSO_INLINED = sub () { $x };
+ }
+
If you really want a subroutine with a C<()> prototype that returns a
lexical variable you can easily force it to not be inlined by adding
an explicit C<return>:
print RT_79908(); # prints 79908
The easiest way to tell if a subroutine was inlined is by using
-L<B::Deparse>, consider this example of two subroutines returning
+L<B::Deparse>. Consider this example of two subroutines returning
C<1>, one with a C<()> prototype causing it to be inlined, and one
without (with deparse output truncated for clarity):
you need to be able to redefine the subroutine, you need to ensure
that it isn't inlined, either by dropping the C<()> prototype (which
changes calling semantics, so beware) or by thwarting the inlining
-mechanism in some other way, e.g. by adding an explicit C<return>:
+mechanism in some other way, e.g. by adding an explicit C<return>, as
+mentioned above:
sub not_inlined () { return 23 }
sleep(15); # Let thread run for awhile
sub sub1 {
- $a = 0;
+ my $count = 0;
while (1) {
- $a++;
- print("\$a is $a\n");
+ $count++;
+ print("\$count is $count\n");
sleep(1);
}
}
use threads;
use threads::shared;
- my $a :shared = 1;
+ my $x :shared = 1;
my $thr1 = threads->create(\&sub1);
my $thr2 = threads->create(\&sub2);
$thr1->join();
$thr2->join();
- print("$a\n");
+ print("$x\n");
- sub sub1 { my $foo = $a; $a = $foo + 1; }
- sub sub2 { my $bar = $a; $a = $bar + 1; }
+ sub sub1 { my $foo = $x; $x = $foo + 1; }
+ sub sub2 { my $bar = $x; $x = $bar + 1; }
-What do you think C<$a> will be? The answer, unfortunately, is I<it
-depends>. Both C<sub1()> and C<sub2()> access the global variable C<$a>, once
+What do you think C<$x> will be? The answer, unfortunately, is I<it
+depends>. Both C<sub1()> and C<sub2()> access the global variable C<$x>, once
to read and once to write. Depending on factors ranging from your
thread implementation's scheduling algorithm to the phase of the moon,
-C<$a> can be 2 or 3.
+C<$x> can be 2 or 3.
Race conditions are caused by unsynchronized access to shared
data. Without explicit synchronization, there's no way to be sure that
possibility of error:
use threads;
- my $a :shared = 2;
- my $b :shared;
- my $c :shared;
- my $thr1 = threads->create(sub { $b = $a; $a = $b + 1; });
- my $thr2 = threads->create(sub { $c = $a; $a = $c + 1; });
+ my $x :shared = 2;
+ my $y :shared;
+ my $z :shared;
+ my $thr1 = threads->create(sub { $y = $x; $x = $y + 1; });
+ my $thr2 = threads->create(sub { $z = $x; $x = $z + 1; });
$thr1->join();
$thr2->join();
-Two threads both access C<$a>. Each thread can potentially be interrupted
-at any point, or be executed in any order. At the end, C<$a> could be 3
-or 4, and both C<$b> and C<$c> could be 2 or 3.
+Two threads both access C<$x>. Each thread can potentially be interrupted
+at any point, or be executed in any order. At the end, C<$x> could be 3
+or 4, and both C<$y> and C<$z> could be 2 or 3.
-Even C<$a += 5> or C<$a++> are not guaranteed to be atomic.
+Even C<$x += 5> or C<$x++> are not guaranteed to be atomic.
Whenever your program accesses data or resources that can be accessed
by other threads, you must take steps to coordinate access or risk
use threads;
- my $a :shared = 4;
- my $b :shared = 'foo';
+ my $x :shared = 4;
+ my $y :shared = 'foo';
my $thr1 = threads->create(sub {
- lock($a);
+ lock($x);
sleep(20);
- lock($b);
+ lock($y);
});
my $thr2 = threads->create(sub {
- lock($b);
+ lock($y);
sleep(20);
- lock($a);
+ lock($x);
});
This program will probably hang until you kill it. The only way it
first. A guaranteed-to-hang version is more complicated, but the
principle is the same.
-The first thread will grab a lock on C<$a>, then, after a pause during which
+The first thread will grab a lock on C<$x>, then, after a pause during which
the second thread has probably had time to do some work, try to grab a
-lock on C<$b>. Meanwhile, the second thread grabs a lock on C<$b>, then later
-tries to grab a lock on C<$a>. The second lock attempt for both threads will
+lock on C<$y>. Meanwhile, the second thread grabs a lock on C<$y>, then later
+tries to grab a lock on C<$x>. The second lock attempt for both threads will
block, each waiting for the other to release its lock.
This condition is called a deadlock, and it occurs whenever two or
There are a number of ways to handle this sort of problem. The best
way is to always have all threads acquire locks in the exact same
-order. If, for example, you lock variables C<$a>, C<$b>, and C<$c>, always lock
-C<$a> before C<$b>, and C<$b> before C<$c>. It's also best to hold on to locks for
+order. If, for example, you lock variables C<$x>, C<$y>, and C<$z>, always lock
+C<$x> before C<$y>, and C<$y> before C<$z>. It's also best to hold on to locks for
as short a period of time to minimize the risks of deadlock.
The other synchronization primitives described below can suffer from
Since kernel threading can interrupt a thread at any time, they will
uncover some of the implicit locking assumptions you may make in your
-program. For example, something as simple as C<$a = $a + 2> can behave
-unpredictably with kernel threads if C<$a> is visible to other
-threads, as another thread may have changed C<$a> between the time it
+program. For example, something as simple as C<$x = $x + 2> can behave
+unpredictably with kernel threads if C<$x> is visible to other
+threads, as another thread may have changed C<$x> between the time it
was fetched on the right hand side and the time the new value is
stored.
The subscript separator for multidimensional array emulation. If you
refer to a hash element as
- $foo{$a,$b,$c}
+ $foo{$x,$y,$z}
it really means
- $foo{join($;, $a, $b, $c)}
+ $foo{join($;, $x, $y, $z)}
But don't put
- @foo{$a,$b,$c} # a slice--note the @
+ @foo{$x,$y,$z} # a slice--note the @
which means
- ($foo{$a},$foo{$b},$foo{$c})
+ ($foo{$x},$foo{$y},$foo{$z})
Default is "\034", the same as SUBSEP in B<awk>. If your keys contain
binary data there might not be any safe value for C<$;>.
if (PL_op->op_flags & OPf_STACKED)
sv = POPs;
- else if (PL_op->op_private & OPpTARGET_MY)
+ else if (ARGTARG)
sv = GETTARGET;
else {
sv = DEFSV;
/* Lvalue operators. */
-static void
+static size_t
S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
{
STRLEN len;
char *s;
+ size_t count = 0;
PERL_ARGS_ASSERT_DO_CHOMP;
if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
- return;
+ return 0;
if (SvTYPE(sv) == SVt_PVAV) {
I32 i;
AV *const av = MUTABLE_AV(sv);
for (i = 0; i <= max; i++) {
sv = MUTABLE_SV(av_fetch(av, i, FALSE));
if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
- do_chomp(retval, sv, chomping);
+ count += do_chomp(retval, sv, chomping);
}
- return;
+ return count;
}
else if (SvTYPE(sv) == SVt_PVHV) {
HV* const hv = MUTABLE_HV(sv);
HE* entry;
(void)hv_iterinit(hv);
while ((entry = hv_iternext(hv)))
- do_chomp(retval, hv_iterval(hv,entry), chomping);
- return;
+ count += do_chomp(retval, hv_iterval(hv,entry), chomping);
+ return count;
}
else if (SvREADONLY(sv)) {
Perl_croak_no_modify();
}
- else if (SvIsCOW(sv)) {
- sv_force_normal_flags(sv, 0);
- }
if (PL_encoding) {
if (!SvUTF8(sv)) {
if (RsPARA(PL_rs)) {
if (*s != '\n')
goto nope;
- ++SvIVX(retval);
+ ++count;
while (len && s[-1] == '\n') {
--len;
--s;
- ++SvIVX(retval);
+ ++count;
}
}
else {
if (rslen == 1) {
if (*s != *rsptr)
goto nope;
- ++SvIVX(retval);
+ ++count;
}
else {
if (len < rslen - 1)
s -= rslen - 1;
if (memNE(s, rsptr, rslen))
goto nope;
- SvIVX(retval) += rs_charlen;
+ count += rs_charlen;
}
}
- s = SvPV_force_nomg_nolen(sv);
+ SvPV_force_nomg_nolen(sv);
SvCUR_set(sv, len);
*SvEND(sv) = '\0';
SvNIOK_off(sv);
Safefree(temp_buffer);
} else {
- if (len && !SvPOK(sv))
+ if (len && (!SvPOK(sv) || SvIsCOW(sv)))
s = SvPV_force_nomg(sv, len);
if (DO_UTF8(sv)) {
if (s && len) {
sv_setpvs(retval, "");
SvSETMAGIC(sv);
}
+ return count;
}
dSP; dTARGET;
const bool chomping = PL_op->op_type == OP_SCHOMP;
+ const size_t count = do_chomp(TARG, TOPs, chomping);
if (chomping)
- sv_setiv(TARG, 0);
- do_chomp(TARG, TOPs, chomping);
+ sv_setiv(TARG, count);
SETTARG;
RETURN;
}
{
dSP; dMARK; dTARGET; dORIGMARK;
const bool chomping = PL_op->op_type == OP_CHOMP;
+ size_t count = 0;
- if (chomping)
- sv_setiv(TARG, 0);
while (MARK < SP)
- do_chomp(TARG, *++MARK, chomping);
+ count += do_chomp(TARG, *++MARK, chomping);
+ if (chomping)
+ sv_setiv(TARG, count);
SP = ORIGMARK;
XPUSHTARG;
RETURN;
/* special case for undef: see thread at 2003-03/msg00536.html in archive */
if (inc && !SvOK(TARG))
sv_setiv(TARG, 0);
- SETs(TARG);
+ SETTARG;
return NORMAL;
}
SvGETMAGIC(sv);
}
else {
+ if (UNLIKELY(PL_op->op_private & OPpREPEAT_DOLIST)) {
+ /* The parser saw this as a list repeat, and there
+ are probably several items on the stack. But we're
+ in scalar/void context, and there's no pp_list to save us
+ now. So drop the rest of the items -- robin@kitsite.com
+ */
+ dMARK;
+ if (MARK + 1 < SP) {
+ MARK[1] = TOPm1s;
+ MARK[2] = TOPs;
+ }
+ else {
+ dTOPss;
+ ASSUME(MARK + 1 == SP);
+ XPUSHs(sv);
+ MARK[1] = &PL_sv_undef;
+ }
+ SP = MARK + 2;
+ }
tryAMAGICbin_MG(repeat_amg, AMGf_assign);
sv = POPs;
}
MEXTEND(MARK, max);
if (count > 1) {
while (SP > MARK) {
-#if 0
- /* This code was intended to fix 20010809.028:
-
- $x = 'abcd';
- for (($x =~ /./g) x 2) {
- print chop; # "abcdabcd" expected as output.
- }
-
- * but that change (#11635) broke this code:
-
- $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
-
- * I can't think of a better fix that doesn't introduce
- * an efficiency hit by copying the SVs. The stack isn't
- * refcounted, and mortalisation obviously doesn't
- * Do The Right Thing when the stack has more than
- * one pointer to the same mortal value.
- * .robin.
- */
- if (*SP) {
- *SP = sv_2mortal(newSVsv(*SP));
- SvREADONLY_on(*SP);
- }
-#else
if (*SP) {
if (mod && SvPADTMP(*SP)) {
*SP = sv_mortalcopy(*SP);
}
SvTEMP_off((*SP));
}
-#endif
SP--;
}
MARK++;
else
(void)SvPOK_only(TARG);
- if (PL_op->op_private & OPpREPEAT_DOLIST) {
- /* The parser saw this as a list repeat, and there
- are probably several items on the stack. But we're
- in scalar context, and there's no pp_list to save us
- now. So drop the rest of the items -- robin@kitsite.com
- */
- dMARK;
- SP = MARK;
- }
PUSHTARG;
}
RETURN;
}
}
SPAGAIN;
- if (rvalue) {
+ if (PL_op->op_private & OPpSUBSTR_REPL_FIRST)
+ SP++;
+ else if (rvalue) {
SvSETMAGIC(TARG);
PUSHs(TARG);
}
}
sv_setuv(ret, do_vecget(src, offset, size));
+ if (!lvalue)
+ SvSETMAGIC(ret);
PUSHs(ret);
RETURN;
}
*tmps = '\0';
(void)SvPOK_only(TARG);
SvUTF8_on(TARG);
- XPUSHs(TARG);
+ XPUSHTARG;
RETURN;
}
}
}
- XPUSHs(TARG);
+ XPUSHTARG;
RETURN;
}
/* If Unicode, try to downgrade.
* If not possible, croak.
* Yes, we made this up. */
- SV* const tsv = sv_2mortal(newSVsv(left));
+ SV* const tsv = newSVpvn_flags(tmps, len, SVf_UTF8|SVs_TEMP);
- SvUTF8_on(tsv);
sv_utf8_downgrade(tsv, FALSE);
tmps = SvPV_const(tsv, len);
}
# else
sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
# endif
+ SvUTF8_off(TARG);
SETTARG;
RETURN;
#else
const bool was_tainted = TAINT_get;
if (pm->op_flags & OPf_STACKED)
lhs = args[-1];
- else if (pm->op_private & OPpTARGET_MY)
+ else if (pm->op_targ)
lhs = PAD_SV(pm->op_targ);
else lhs = DEFSV;
SvGETMAGIC(lhs);
SAVETMPS;
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
if (CvISXSUB(cv)) {
- OP* const retop = cx->blk_sub.retop;
SV **newsp;
I32 gimme;
const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
SvREFCNT_dec(arg);
}
+ retop = cx->blk_sub.retop;
/* XS subs don't have a CxSUB, so pop it */
POPBLOCK(cx, PL_curpm);
/* Push a mark for the start of arglist */
PUTBACK;
(void)(*CvXSUB(cv))(aTHX_ cv);
LEAVE;
- PERL_ASYNC_CHECK();
- return retop;
+ goto _return;
}
else {
PADLIST * const padlist = CvPADLIST(cv);
}
}
}
- PERL_ASYNC_CHECK();
- RETURNOP(CvSTART(cv));
+ retop = CvSTART(cv);
+ goto putback_return;
}
}
else {
}
}
- if (do_dump) {
+ else {
+ assert(do_dump);
#ifdef VMS
if (!retop) retop = PL_main_start;
#endif
PL_do_undump = FALSE;
}
+ putback_return:
+ PL_stack_sp = sp;
+ _return:
PERL_ASYNC_CHECK();
- RETURNOP(retop);
+ return retop;
}
PP(pp_exit)
/* set up a scratch pad */
- CvPADLIST(evalcv) = pad_new(padnew_SAVE);
+ CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
if (is_pp_rv2av) {
AV *const av = MUTABLE_AV(sv);
- /* The guts of pp_rv2av, with no intending change to preserve history
- (until such time as we get tools that can do blame annotation across
- whitespace changes. */
+ /* The guts of pp_rv2av */
if (gimme == G_ARRAY) {
SP--;
PUTBACK;
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
- else if (PL_op->op_private & OPpTARGET_MY)
+ else if (ARGTARG)
GETTARGET;
else {
TARG = DEFSV;
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
- else if (PL_op->op_private & OPpTARGET_MY)
+ else if (ARGTARG)
GETTARGET;
else {
TARG = DEFSV;
Pid_t pgrp;
Pid_t pid;
pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
- if (MAXARG > 0) pid = TOPs && TOPi;
+ if (MAXARG > 0) pid = TOPs ? TOPi : 0;
else {
pid = 0;
- XPUSHi(-1);
+ EXTEND(SP,1);
+ SP++;
}
TAINT_PROPER("setpgrp");
const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
SP = MARK;
if (anum == -1)
- RETSETUNDEF;
+ RETPUSHUNDEF;
if (anum != 0) {
PUSHi(anum);
}
#define PERL_ARGS_ASSERT_CLOSEST_COP \
assert(cop)
-PERL_CALLCONV OP* Perl_convert(pTHX_ I32 optype, I32 flags, OP* o)
- __attribute__warn_unused_result__;
-
PERL_CALLCONV const char * Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_COP_FETCH_LABEL \
assert(to); assert(toend); assert(from); assert(fromend); assert(retlen)
PERL_CALLCONV void Perl_despatch_signals(pTHX);
+PERL_CALLCONV_NO_RET OP* Perl_die(pTHX_ const char* pat, ...)
+ __attribute__noreturn__
+ __attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2);
+
+PERL_CALLCONV_NO_RET OP* Perl_die_sv(pTHX_ SV *baseex)
+ __attribute__noreturn__
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DIE_SV \
+ assert(baseex)
+
PERL_CALLCONV_NO_RET void Perl_die_unwind(pTHX_ SV* msv)
__attribute__noreturn__
__attribute__nonnull__(pTHX_1);
PERL_CALLCONV OP* Perl_invert(pTHX_ OP* cmd)
__attribute__warn_unused_result__;
-PERL_CALLCONV bool Perl_io_close(pTHX_ IO* io, bool not_implicit)
+PERL_CALLCONV bool Perl_io_close(pTHX_ IO* io, GV *gv, bool not_implicit, bool warn_on_fail)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_IO_CLOSE \
assert(io)
__attribute__malloc__
__attribute__warn_unused_result__;
+PERL_CALLCONV OP* Perl_newDEFSVOP(pTHX)
+ __attribute__warn_unused_result__;
+
PERL_CALLCONV void Perl_newFORM(pTHX_ I32 floor, OP* o, OP* block);
PERL_CALLCONV OP* Perl_newFOROP(pTHX_ I32 flags, OP* sv, OP* expr, OP* block, OP* cont)
__attribute__malloc__
#define PERL_ARGS_ASSERT_NEWXS \
assert(subaddr); assert(filename)
+PERL_CALLCONV CV * Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_NEWXS_DEFFILE \
+ assert(name); assert(subaddr)
+
PERL_CALLCONV CV * Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags)
__attribute__nonnull__(pTHX_2)
__attribute__nonnull__(pTHX_3);
assert(subaddr); assert(filename)
PERL_CALLCONV CV * Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, XSUBADDR_t subaddr, const char *const filename, const char *const proto, SV **const_svp, U32 flags)
- __attribute__nonnull__(pTHX_3)
- __attribute__nonnull__(pTHX_4);
+ __attribute__nonnull__(pTHX_3);
#define PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS \
- assert(subaddr); assert(filename)
+ assert(subaddr)
PERL_CALLCONV void Perl_new_collate(pTHX_ const char* newcoll);
PERL_CALLCONV void Perl_new_ctype(pTHX_ const char* newctype)
#define PERL_ARGS_ASSERT_NINSTR \
assert(big); assert(bigend); assert(little); assert(lend)
+PERL_CALLCONV_NO_RET void Perl_noperl_die(const char* pat, ...)
+ __attribute__noreturn__
+ __attribute__format__(__printf__,1,2)
+ __attribute__nonnull__(1);
+#define PERL_ARGS_ASSERT_NOPERL_DIE \
+ assert(pat)
+
PERL_CALLCONV int Perl_nothreadhook(pTHX);
PERL_CALLCONV OP* Perl_oopsAV(pTHX_ OP* o)
__attribute__warn_unused_result__
#define PERL_ARGS_ASSERT_OP_CLEAR \
assert(o)
-PERL_CALLCONV SV* Perl_op_const_sv(pTHX_ const OP* o, CV* cv)
- __attribute__warn_unused_result__;
-
PERL_CALLCONV OP* Perl_op_contextualize(pTHX_ OP* o, I32 context)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_OP_CONTEXTUALIZE \
assert(o)
+PERL_CALLCONV OP* Perl_op_convert_list(pTHX_ I32 optype, I32 flags, OP* o)
+ __attribute__warn_unused_result__;
+
PERL_CALLCONV void Perl_op_dump(pTHX_ const OP *o)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_OP_DUMP \
#define PERL_ARGS_ASSERT_WRITE_TO_STDERR \
assert(msv)
-PERL_CALLCONV void Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p, STRLEN api_len)
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK \
- assert(module); assert(api_p)
+PERL_CALLCONV void Perl_xs_boot_epilog(pTHX_ const U32 ax);
+PERL_CALLCONV I32 Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
+ __attribute__nonnull__(2)
+ __attribute__nonnull__(3);
+#define PERL_ARGS_ASSERT_XS_HANDSHAKE \
+ assert(v_my_perl); assert(file)
PERL_CALLCONV void Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, STRLEN xs_len)
__attribute__nonnull__(pTHX_3);
#endif
#if !(defined(_MSC_VER))
-PERL_CALLCONV_NO_RET OP* Perl_die(pTHX_ const char* pat, ...)
- __attribute__noreturn__
- __attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2);
-
-PERL_CALLCONV_NO_RET OP* Perl_die_sv(pTHX_ SV *baseex)
- __attribute__noreturn__
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_DIE_SV \
- assert(baseex)
-
PERL_CALLCONV_NO_RET int Perl_magic_regdatum_set(pTHX_ SV* sv, MAGIC* mg)
__attribute__noreturn__
__attribute__nonnull__(pTHX_1)
#define PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET \
assert(sv); assert(mg)
-PERL_CALLCONV_NO_RET char* Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
- __attribute__noreturn__
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_5);
-#define PERL_ARGS_ASSERT_SCREAMINSTR \
- assert(bigstr); assert(littlestr); assert(old_posp)
-
-# if defined(PERL_IMPLICIT_CONTEXT)
-PERL_CALLCONV_NO_RET OP* Perl_die_nocontext(const char* pat, ...)
- __attribute__noreturn__
- __attribute__format__null_ok__(__printf__,1,2);
-
-# endif
#endif
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
PERL_CALLCONV char* Perl_my_bzero(char* loc, I32 len)
assert(sv)
PERL_CALLCONV SV* Perl_pad_sv(pTHX_ PADOFFSET po);
+PERL_CALLCONV void Perl_set_padlist(pTHX_ CV * cv, PADLIST * padlist)
+ __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SET_PADLIST \
+ assert(cv)
+
# if defined(PERL_IN_PAD_C)
STATIC void S_cv_dump(pTHX_ const CV *cv, const char *title)
__attribute__nonnull__(pTHX_1)
#define PERL_ARGS_ASSERT_DEB_NOCONTEXT \
assert(pat)
+PERL_CALLCONV_NO_RET OP* Perl_die_nocontext(const char* pat, ...)
+ __attribute__noreturn__
+ __attribute__format__null_ok__(__printf__,1,2);
+
PERL_CALLCONV char* Perl_form_nocontext(const char* pat, ...)
__attribute__format__(__printf__,1,2)
__attribute__nonnull__(1);
#define PERL_ARGS_ASSERT_WARNER_NOCONTEXT \
assert(pat)
-# if defined(_MSC_VER)
-PERL_CALLCONV OP* Perl_die_nocontext(const char* pat, ...)
- __attribute__format__null_ok__(__printf__,1,2);
-
-# endif
#endif
#if defined(PERL_IMPLICIT_SYS)
PERL_CALLCONV PerlInterpreter* perl_alloc_using(struct IPerlMem *ipM, struct IPerlMem *ipMS, struct IPerlMem *ipMP, struct IPerlEnv *ipE, struct IPerlStdIO *ipStd, struct IPerlLIO *ipLIO, struct IPerlDir *ipD, struct IPerlSock *ipS, struct IPerlProc *ipP)
#define PERL_ARGS_ASSERT_MY_KID \
assert(imopsp)
-STATIC OP* S_newDEFSVOP(pTHX)
- __attribute__warn_unused_result__;
-
STATIC OP* S_newGIVWHENOP(pTHX_ OP* cond, OP *block, I32 enter_opcode, I32 leave_opcode, PADOFFSET entertarg)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_NEWGIVWHENOP \
#define PERL_ARGS_ASSERT_NO_FH_ALLOWED \
assert(o)
-STATIC void S_null_listop_in_list_context(pTHX_ OP* o)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT \
- assert(o)
-
PERL_STATIC_INLINE OP* S_op_integerize(pTHX_ OP *o)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_OP_INTEGERIZE \
#endif
#if defined(PERL_IN_PP_C)
-STATIC void S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
+STATIC size_t S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_DO_CHOMP \
#endif
#if defined(PERL_IN_UTF8_C)
-STATIC UV S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
+STATIC UV S_check_locale_boundary_crossing(pTHX_ const char * const func_name, const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_3)
- __attribute__nonnull__(pTHX_4);
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_4)
+ __attribute__nonnull__(pTHX_5);
#define PERL_ARGS_ASSERT_CHECK_LOCALE_BOUNDARY_CROSSING \
- assert(p); assert(ustrp); assert(lenp)
+ assert(func_name); assert(p); assert(ustrp); assert(lenp)
PERL_STATIC_INLINE bool S_is_utf8_common(pTHX_ const U8 *const p, SV **swash, const char * const swashname, SV* const invlist)
__attribute__warn_unused_result__
PERL_CALLCONV PADLIST * Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
__attribute__warn_unused_result__
+ __attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_PADLIST_DUP \
- assert(param)
+ assert(srcpad); assert(param)
PERL_CALLCONV yy_parser* Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_PERLIO_READ \
assert(vbuf)
+PERL_CALLCONV void Perl_PerlIO_restore_errno(pTHX_ PerlIO *f);
+PERL_CALLCONV void Perl_PerlIO_save_errno(pTHX_ PerlIO *f);
PERL_CALLCONV int Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence);
PERL_CALLCONV void Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt);
PERL_CALLCONV void Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR *ptr, SSize_t cnt);
#endif
#if defined(_MSC_VER)
-PERL_CALLCONV OP* Perl_die(pTHX_ const char* pat, ...)
- __attribute__format__null_ok__(__printf__,pTHX_1,pTHX_2);
-
-PERL_CALLCONV OP* Perl_die_sv(pTHX_ SV *baseex)
- __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_DIE_SV \
- assert(baseex)
-
PERL_CALLCONV int Perl_magic_regdatum_set(pTHX_ SV* sv, MAGIC* mg)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET \
assert(sv); assert(mg)
-PERL_CALLCONV char* Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2)
- __attribute__nonnull__(pTHX_5);
-#define PERL_ARGS_ASSERT_SCREAMINSTR \
- assert(bigstr); assert(littlestr); assert(old_posp)
-
#endif
#ifdef PERL_CORE
# include "pp_proto.h"
{
PerlIO_printf(Perl_debug_log,
"%*sstudy_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
- ((int) depth*2), "", (long)stopparen,
+ (int)(depth*2), "", (long)stopparen,
(unsigned long)RExC_study_chunk_recursed_count,
(unsigned long)depth, (unsigned long)recursed_depth,
scan,
(( j - 1 ) * RExC_study_chunk_recursed_bytes), i)
)
) {
- PerlIO_printf(Perl_debug_log," %d",i);
+ PerlIO_printf(Perl_debug_log," %d",(int)i);
break;
}
}
{
/* Fatal warnings may leak the regexp without this: */
SAVEFREESV(RExC_rx_sv);
- ckWARNreg(RExC_parse,
- "Quantifier unexpected on zero-length expression");
+ Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
+ "Quantifier unexpected on zero-length expression "
+ "in regex m/%"UTF8f"/",
+ UTF8fARG(UTF, RExC_end - RExC_precomp,
+ RExC_precomp));
(void)ReREFCNT_inc(RExC_rx_sv);
}
min++;
if (flags & SCF_DO_STCLASS) {
bool invert = 0;
- SV* my_invlist = sv_2mortal(_new_invlist(0));
+ SV* my_invlist = NULL;
U8 namedclass;
/* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
/* FALLTHROUGH */
case POSIXA:
if (FLAGS(scan) == _CC_ASCII) {
- my_invlist = PL_XPosix_ptrs[_CC_ASCII];
+ my_invlist = invlist_clone(PL_XPosix_ptrs[_CC_ASCII]);
}
else {
_invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)],
assert(flags & SCF_DO_STCLASS_OR);
ssc_union(data->start_class, my_invlist, invert);
}
+ SvREFCNT_dec(my_invlist);
}
if (flags & SCF_DO_STCLASS_OR)
ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
/* Add the range from 'start' to 'end' inclusive to the inversion list's
* set. A pointer to the inversion list is returned. This may actually be
* a new list, in which case the passed in one has been destroyed. The
- * passed in inversion list can be NULL, in which case a new one is created
+ * passed-in inversion list can be NULL, in which case a new one is created
* with just the one range in it */
SV* range_invlist;
RExC_recurse_count++;
DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
"%*s%*s Recurse #%"UVuf" to %"IVdf"\n",
- 22, "| |", 1 + depth * 2, "",
+ 22, "| |", (int)(depth * 2 + 1), "",
(UV)ARG(ret), (IV)ARG2L(ret)));
}
RExC_seen |= REG_RECURSE_SEEN;
{
DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
"%*s%*s Setting open paren #%"IVdf" to %d\n",
- 22, "| |", 1+2 * depth, "",
+ 22, "| |", (int)(depth * 2 + 1), "",
(IV)parno, REG_NODE_NUM(ret)));
RExC_open_parens[parno-1]= ret;
}
if (!SIZE_ONLY && RExC_seen & REG_RECURSE_SEEN) {
DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
"%*s%*s Setting close paren #%"IVdf" to %d\n",
- 22, "| |", 1+2 * depth, "", (IV)parno, REG_NODE_NUM(ender)));
+ 22, "| |", (int)(depth * 2 + 1), "", (IV)parno, REG_NODE_NUM(ender)));
RExC_close_parens[parno-1]= ender;
if (RExC_nestroot == parno)
RExC_nestroot = 0;
if (! len_passed_in) {
if (UTF) {
- if (UNI_IS_INVARIANT(code_point)) {
+ if (UVCHR_IS_INVARIANT(code_point)) {
if (LOC || ! FOLD) { /* /l defers folding until runtime */
*character = (U8) code_point;
}
* the simple case just below.) */
UV folded;
- if (isASCII(ender)) {
+ if (isASCII_uni(ender)) {
folded = toFOLD(ender);
*(s)++ = (U8) folded;
}
continue;
}
- /* Here, we have a single value, and <prevvalue> is the beginning of
- * the range, if any; or <value> if not */
+ /* Here, we have a single value this time through the loop, 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 */
PERL_UNUSED_ARG(o);
PERL_UNUSED_ARG(prog);
PERL_UNUSED_ARG(reginfo);
+ PERL_UNUSED_ARG(pRExC_state);
#endif /* DEBUGGING */
}
my $table_ref = shift;
my $name = shift;
+ # Tables in hex easier to debug, but don't fit into 80 columns
+ my $print_in_hex = 0;
+
die "Requres 256 entries in table $name, got @$table_ref" if @$table_ref != 256;
print $out_fh "EXTCONST U8 $name\[\] = {\n";
+ print $out_fh "/* _0 _1 _2 _3 _4 _5 _6 _7 _8 _9 _A _B _C _D _E _F */\n" if $print_in_hex;
for my $i (0 .. 255) {
- printf $out_fh "%4d", $table_ref->[$i];
- #printf $out_fh " 0x%02X", $table_ref->[$i];
+ if ($print_in_hex) {
+ printf $out_fh "/* %X_ */ ", $i / 16 if $i % 16 == 0;
+ printf $out_fh " 0x%02X", $table_ref->[$i];
+ }
+ else {
+ printf $out_fh "%4d", $table_ref->[$i];
+ }
+ printf $out_fh " /* %X_ */", $i / 16 if $print_in_hex && $i % 16 == 15;
print $out_fh ",", if $i < 255;
print $out_fh "\n" if $i % 16 == 15;
}
+ print $out_fh "/* _0 _1 _2 _3 _4 _5 _6 _7 _8 _9 _A _B _C _D _E _F */\n" if $print_in_hex;
print $out_fh "};\n\n";
}
desc => 'Extra data for restricted hashes' },
arylen_p => { char => '@', value_magic => 1,
desc => 'To move arylen out of XPVAV' },
- ext => { char => '~', desc => 'Available for use by extensions' },
+ ext => { char => '~', desc => 'Available for use by extensions',
+ readonly_acceptable => 1 },
checkcall => { char => ']', value_magic => 1, vtable => 'checkcall',
desc => 'Inlining/mutation of call to this CV'},
debugvar => { char => '*', desc => '$DB::single, signal, trace vars',
addbits('aelem',
7 => qw(OPpLVAL_INTRO LVINTRO),
- '5..6' => {
+ '4..5' => {
mask_def => 'OPpDEREF',
enum => [ qw(
1 OPpDEREF_AV DREFAV
3 OPpDEREF_SV DREFSV
)],
},
- 4 => qw(OPpLVAL_DEFER LVDEFER),
+ 6 => qw(OPpLVAL_DEFER LVDEFER),
);
Here for the op C<aelem>, bits 4 and 7 (bits are numbered 0..7) are
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),
-
);
}
# Safe to set if the ppcode uses:
# tryAMAGICbin, tryAMAGICun, SETn, SETi, SETu, PUSHn, PUSHTARG, SETTARG,
# SETs(TARG), XPUSHn, XPUSHu,
+# but make sure set-magic is invoked separately for SETs(TARG) (or change
+# it to SETTARG).
#
# Unsafe to set if the ppcode uses dTARG or [X]RETPUSH[YES|NO|UNDEF]
#
+# Only the code paths that handle scalar rvalue context matter. If dTARG
+# or RETPUSHNO occurs only in list or lvalue paths, T is safe.
+#
# lt and friends do SETs (including ncmp, but not scmp)
#
# Additional mode of failure: the opcode can modify TARG before it "used"
# 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
+# pack - unknown whether it is safe
# sprintf: is calling do_sprintf(TARG,...) which can act on TARG
# before other args are processed.
#
# 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).
+# concat - pp_concat special-cases TARG==arg to avoid
+# "additional mode of failure"
#
# pp_ctl.c
# mapwhile flip caller not OK (not always setting)
# autovivify: Want ref to something
for (qw(rv2gv rv2sv padsv aelem helem entersub)) {
- addbits($_, '5..6' => {
+ addbits($_, '4..5' => {
mask_def => 'OPpDEREF',
enum => [ qw(
1 OPpDEREF_AV DREFAV
# Defer creation of array/hash elem
-addbits($_, 4 => qw(OPpLVAL_DEFER LVDEFER)) for qw(aelem helem);
+addbits($_, 6 => qw(OPpLVAL_DEFER LVDEFER)) for qw(aelem helem);
# 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()
+addbits($_, 6 => qw(OPpOUR_INTRO OURINTR)) # Variable was in an our()
for qw(gvsv rv2sv rv2av rv2hv enteriter split);
for (qw(rv2hv padhv)) {
addbits($_, # e.g. %hash in (%hash || $foo) ...
+ 4 => qw(OPpMAYBE_TRUEBOOL BOOL?), # ... cx not known till run time
5 => qw(OPpTRUEBOOL BOOL), # ... in void cxt
- 6 => qw(OPpMAYBE_TRUEBOOL BOOL?), # ... cx not known till run time
);
}
-addbits($_, 4 => qw(OPpPAD_STATE STATE)) for qw(padav padhv padsv lvavref
+addbits($_, 6 => qw(OPpPAD_STATE STATE)) for qw(padav padhv padsv lvavref
lvref refassign pushmark);
# 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
+# 4 OPpDEREF_AV context
+# 5 OPpDEREF_HV context OPpMAY_RETURN_CONSTANT parser/context
+# 6 OPpENTERSUB_DB check OPpENTERSUB_DB
# 7 OPpLVAL_INTRO context OPpENTERSUB_NOPAREN parser
# NB: OPpHINT_STRICT_REFS must equal HINT_STRICT_REFS
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
+ # 4..5 => OPpDEREF, already defined above
+ 6 => qw(OPpENTERSUB_DB DBG ), # Debug subroutine
# 7 => OPpLVAL_INTRO, already defined above
);
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 ),
+ 5 => qw(OPpMAY_RETURN_CONSTANT CONST ),
+ 6 => qw(OPpENTERSUB_DB DBG ), # Debug subroutine
7 => qw(OPpENTERSUB_NOPAREN NO() ), # bare sub call (without parens)
);
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
+ 6 => qw(OPpALLOW_FAKE FAKE), # OK to return fake glob
);
-# OPpLVREF_TYPE must not conflict with generic magic flags in mg.h.
addbits($_,
2 => qw(OPpLVREF_ELEM ELEM ),
3 => qw(OPpLVREF_ITER ITER ),
-'5..6'=> {
+'4..5'=> {
mask_def => 'OPpLVREF_TYPE',
enum => [ qw(
0 OPpLVREF_SV SV
# Format is "this function" => "does these op names"
my @raw_alias = (
Perl_do_kv => [qw( keys values )],
- Perl_unimplemented_op => [qw(padany mapstart custom)],
+ Perl_unimplemented_op => [qw(padany custom)],
# All the ops with a body of { return NORMAL; }
Perl_pp_null => [qw(scalar regcmaybe lineseq scope)],
spwent epwent sgrent egrent)],
Perl_pp_shostent => [qw(snetent sprotoent sservent)],
Perl_pp_aelemfast => ['aelemfast_lex'],
+ Perl_pp_grepstart => ['mapstart'],
);
while (my ($func, $names) = splice @raw_alias, 0, 2) {
@
@=head1 DESCRIPTION
@
-@This module provides three global hashes:
+@This module provides four global hashes:
@
@ %B::Op_private::bits
@ %B::Op_private::defines
@ %B::Op_private::labels
+@ %B::Op_private::ops_using
@
@which contain information about the per-op meanings of the bits in the
@op_private field.
@If the label equals '-', then Concise will treat the bit as a raw bit and
@not try to display it symbolically.
@
+@=head2 C<%ops_using>
+@
+@For each define, this gives a reference to an array of op names that use
+@the flag.
+@
+@ @ops_using_lvintro = @{ $B::Op_private::ops_using{OPp_LVAL_INTRO} };
+@
@=cut
package B::Op_private;
my $v = (::perl_version())[3];
print $fh qq{\nour \$VERSION = "$v";\n\n};
+ my %ops_using;
+
# for each flag/bit combination, find the ops which use it
my %combos;
for my $op (sort keys %FLAGS) {
next unless defined $e;
next if ref $e; # bit field, not flag
push @{$combos{$e}{$bit}}, $op;
+ push @{$ops_using{$e}}, $op;
}
}
printf $fh " %-23s => '%s',\n", $_ , $LABELS{$_} for sort keys %LABELS;
print $fh ");\n";
+ # %ops_using
+ print $fh "\n\nour %ops_using = (\n";
+ # Save memory by using the same array wherever possible.
+ my %flag_by_op_list;
+ my $pending = '';
+ for my $flag (sort keys %ops_using) {
+ my $op_list = $ops_using{$flag} = "@{$ops_using{$flag}}";
+ if (!exists $flag_by_op_list{$op_list}) {
+ $flag_by_op_list{$op_list} = $flag;
+ printf $fh " %-23s => %s,\n", $flag , "[qw($op_list)]"
+ }
+ else {
+ $pending .= "\$ops_using{$flag} = "
+ . "\$ops_using{$flag_by_op_list{$op_list}};\n";
+ }
+ }
+ print $fh ");\n\n$pending";
+
}
my $bitdef_count = 0;
my %not_seen = %FLAGS;
+ my @seen_bitdefs;
+ my %seen_bitdefs;
my $opnum = -1;
for my $op (sort { $opnum{$a} <=> $opnum{$b} } keys %opnum) {
}
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));
+ my $key = join(', ', map(sprintf("0x%04x", $_), @bitdefs));
+ if (!$seen_bitdefs{$key}) {
+ $index = $bitdef_count;
+ $bitdef_count += @bitdefs;
+ push @seen_bitdefs,
+ $seen_bitdefs{$key} = [$index, $key];
+ }
+ else {
+ $index = $seen_bitdefs{$key}[0];
+ }
+ push @{$seen_bitdefs{$key}}, $op;
}
else {
$index = -1;
if (%not_seen) {
die "panic: unprocessed ops: ". join(',', keys %not_seen);
}
+ for (@seen_bitdefs) {
+ local $" = ", ";
+ $PL_op_private_bitdefs .= " $$_[1], /* @$_[2..$#$_] */\n";
+ }
}
regcmaybe regexp internal guard ck_fun s1 S
regcreset regexp internal reset ck_fun s1 S
regcomp regexp compilation ck_null s| S
-match pattern match (m//) ck_match d/
+match pattern match (m//) ck_match /
qr pattern quote (qr//) ck_match s/
-subst substitution (s///) ck_match dis/ S
-substcont substitution iterator ck_null dis|
+subst substitution (s///) ck_match is/ S
+substcont substitution iterator ck_null is|
trans transliteration (tr///) ck_match is" S
# y///r
transr transliteration (tr///) ck_match is" S
i_preinc integer preincrement (++) ck_lfun dis1 S
predec predecrement (--) ck_lfun dIs1 S
i_predec integer predecrement (--) ck_lfun dis1 S
-postinc postincrement (++) ck_lfun dIst1 S
-i_postinc integer postincrement (++) ck_lfun disT1 S
-postdec postdecrement (--) ck_lfun dIst1 S
-i_postdec integer postdecrement (--) ck_lfun disT1 S
+postinc postincrement (++) ck_lfun Ist1 S
+i_postinc integer postincrement (++) ck_lfun ist1 S
+postdec postdecrement (--) ck_lfun Ist1 S
+i_postdec integer postdecrement (--) ck_lfun ist1 S
# Ordinary operators.
i_divide integer division (/) ck_null ifsT2 S S
modulo modulus (%) ck_null IifsT2 S S
i_modulo integer modulus (%) ck_null ifsT2 S S
-repeat repeat (x) ck_repeat fmt2 L S
+repeat repeat (x) ck_repeat fmT2 L S
add addition (+) ck_null IfsT2 S S
i_add integer addition (+) ck_null ifsT2 S S
bit_or bitwise or (|) ck_bitop fst2 S S
negate negation (-) ck_null Ifst1 S
-i_negate integer negation (-) ck_null ifsT1 S
+i_negate integer negation (-) ck_null ifst1 S
not not ck_null ifs1 S
complement 1's complement (~) ck_bitop fst1 S
length length ck_length ifsTu% S?
substr substr ck_substr st@ S S S? S?
-vec vec ck_fun ist@ S S S
+vec vec ck_fun isT@ S S S
index index ck_index isT@ S S S?
rindex rindex ck_index isT@ S S S?
aslice array slice ck_null m@ A L
kvaslice index/value array slice ck_null m@ A L
-aeach each on array ck_each % A
+aeach each on array ck_each d% A
akeys keys on array ck_each t% A
-avalues values on array ck_each t% A
+avalues values on array ck_each dt% A
# Hashes.
-each each ck_each % H
-values values ck_each t% H
+each each ck_each d% H
+values values ck_each dt% H
keys keys ck_each t% H
delete delete ck_delete % S
exists exists ck_exists is% S
unpack unpack ck_fun u@ S S?
pack pack ck_fun fmst@ S L
-split split ck_split t@ S S S
+split split ck_split T@ S S S
join join or string ck_join fmst@ S L
# List operators.
list list ck_null m@ L
lslice list slice ck_null 2 H L L
-anonlist anonymous list ([]) ck_fun ms@ L
+anonlist anonymous array ([]) ck_fun ms@ L
anonhash anonymous hash ({}) ck_fun ms@ L
splice splice ck_fun m@ A S? S? L
pop pop ck_shift s% A?
shift shift ck_shift s% A?
unshift unshift ck_fun imsT@ A L
-sort sort ck_sort dm@ C? L
+sort sort ck_sort m@ C? L
reverse reverse ck_fun mt@ L
-grepstart grep ck_grep dm@ C L
-grepwhile grep iterator ck_null dt|
+grepstart grep ck_grep m@ C L
+grepwhile grep iterator ck_null t|
-mapstart map ck_grep dm@ C L
-mapwhile map iterator ck_null dt|
+mapstart map ck_grep m@ C L
+mapwhile map iterator ck_null t|
# Range stuff.
or logical or (||) ck_null |
xor logical xor ck_null fs2 S S
dor defined or (//) ck_null |
-cond_expr conditional expression ck_null d|
+cond_expr conditional expression ck_null |
andassign logical and assignment (&&=) ck_null s|
orassign logical or assignment (||=) ck_null s|
dorassign defined or assignment (//=) ck_null s|
leavesublv lvalue subroutine return ck_null 1
caller caller ck_fun t% S?
warn warn ck_fun imst@ L
-die die ck_fun dimst@ L
+die die ck_fun imst@ L
reset symbol reset ck_fun is% S?
lineseq line sequence ck_null @
iter foreach loop iterator ck_null 0
enterloop loop entry ck_null d{
leaveloop loop exit ck_null 2
-return return ck_return dm@ L
-last last ck_null ds}
-next next ck_null ds}
-redo redo ck_null ds}
+return return ck_return m@ L
+last last ck_null s}
+next next ck_null s}
+redo redo ck_null s}
dump dump ck_null ds}
-goto goto ck_null ds}
-exit exit ck_fun ds% S?
+goto goto ck_null s}
+exit exit ck_fun s% S?
method_named method with known name ck_null d.
entergiven given() ck_null d|
tie tie ck_fun idms@ R S L
untie untie ck_fun is% R
-tied tied ck_fun s% R
+tied tied ck_fun ds% R
dbmopen dbmopen ck_fun is@ H S S
dbmclose dbmclose ck_fun is% H
getc getc ck_eof st% F?
read read ck_fun imst@ F R S S?
-enterwrite write ck_fun dis% F?
+enterwrite write ck_fun is% F?
leavewrite write exit ck_null 1
prtf printf ck_listiob ims@ F? L
wait wait ck_null isT0
waitpid waitpid ck_fun isT@ S S
system system ck_exec imsT@ S? L
-exec exec ck_exec dimsT@ S? L
-kill kill ck_fun dimsT@ L
+exec exec ck_exec imsT@ S? L
+kill kill ck_fun imsT@ L
getppid getppid ck_null isT0
getpgrp getpgrp ck_fun isT% S?
setpgrp setpgrp ck_fun isT@ S? S?
custom unknown custom operator ck_null 0
# For smart dereference for each/keys/values
-reach each on reference ck_each % S
+reach each on reference ck_each d% S
rkeys keys on reference ck_each t% S
-rvalues values on reference ck_each t% S
+rvalues values on reference ck_each dt% S
# For CORE:: subs
coreargs CORE:: subroutine ck_null $
'missing' => [ 5.021, DEFAULT_OFF],
'redundant' => [ 5.021, DEFAULT_OFF],
+ 'locale' => [ 5.021, DEFAULT_ON],
#'default' => [ 5.008, DEFAULT_ON ],
}],
__END__
package warnings;
-our $VERSION = '1.28';
+our $VERSION = '1.29';
# Verify that we're called correctly so that warnings will work.
# see also strict.pm.
goto fail;
}
+ RX_MATCH_UTF8_set(rx,utf8_target);
reginfo->is_utf8_target = cBOOL(utf8_target);
reginfo->info_aux = NULL;
reginfo->strbeg = strbeg;
}
RX_MATCH_TAINTED_off(rx);
+ RX_MATCH_UTF8_set(rx, utf8_target);
reginfo->prog = rx; /* Yes, sorry that this is confusing. */
reginfo->intuit = 0;
if (RXp_PAREN_NAMES(prog))
(void)hv_iterinit(RXp_PAREN_NAMES(prog));
- RX_MATCH_UTF8_set(rx, utf8_target);
-
/* make sure $`, $&, $', and $digit will work later */
if ( !(flags & REXEC_NOT_FIRST) )
S_reg_set_capture_string(aTHX_ rx,
SvFLAGS(sv) &=~ (SVf_OK|SVf_IVisUV|SVf_UTF8);
break;
}
+ SvPADTMP_off(sv);
SvPADSTALE_on(sv); /* mark as no longer live */
}
else { /* Someone has a claim on this, so abandon it. */
- assert(!(SvFLAGS(sv) & SVs_PADTMP));
switch (SvTYPE(sv)) { /* Console ourselves with a new value */
case SVt_PVAV: *svp = MUTABLE_SV(newAV()); break;
case SVt_PVHV: *svp = MUTABLE_SV(newHV()); break;
PERL_UNUSED_RESULT(Gconvert((NV)(nv), (int)ndig, 0, buffer))
#endif
-#ifdef PERL_NEW_COPY_ON_WRITE
-# ifndef SV_COW_THRESHOLD
+#ifndef SV_COW_THRESHOLD
# define SV_COW_THRESHOLD 0 /* COW iff len > K */
-# endif
-# ifndef SV_COWBUF_THRESHOLD
+#endif
+#ifndef SV_COWBUF_THRESHOLD
# define SV_COWBUF_THRESHOLD 1250 /* COW iff len > K */
-# endif
-# ifndef SV_COW_MAX_WASTE_THRESHOLD
+#endif
+#ifndef SV_COW_MAX_WASTE_THRESHOLD
# define SV_COW_MAX_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
-# endif
-# ifndef SV_COWBUF_WASTE_THRESHOLD
+#endif
+#ifndef SV_COWBUF_WASTE_THRESHOLD
# define SV_COWBUF_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
-# endif
-# ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
+#endif
+#ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
# define SV_COW_MAX_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
-# endif
-# ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
+#endif
+#ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
# define SV_COWBUF_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
-# endif
#endif
/* Work around compiler warnings about unsigned >= THRESHOLD when thres-
hold is 0. */
# define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
/* Whilst I'd love to do this, it seems that things like to check on
unreferenced scalars
-# define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
+# define POISON_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
*/
-# define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
+# define POISON_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
PoisonNew(&SvREFCNT(sv), 1, U32)
#else
# define SvARENA_CHAIN(sv) SvANY(sv)
# define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
-# define POSION_SV_HEAD(sv)
+# define POISON_SV_HEAD(sv)
#endif
/* Mark an SV head as unused, and add to free list.
MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
DEBUG_SV_SERIAL(p); \
FREE_SV_DEBUG_FILE(p); \
- POSION_SV_HEAD(p); \
+ POISON_SV_HEAD(p); \
SvFLAGS(p) = SVTYPEMASK; \
if (!(old_flags & SVf_BREAK)) { \
SvARENA_CHAIN_SET(p, PL_sv_root); \
if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
|| (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
return;
+ if (SvPAD_NAME(sv))
+ return;
(void)curse(sv, 0);
}
* IV or UV at same time to avoid this. */
/* IV-over-UV optimisation - choose to cache IV if possible */
- if (UNLIKELY(Perl_isinfnan(SvNVX(sv))))
- return FALSE;
-
if (SvTYPE(sv) == SVt_NV)
sv_upgrade(sv, SVt_PVNV);
certainly cast into the IV range at IV_MAX, whereas the correct
answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
cases go to UV */
+#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 (SvNVX(sv) == (NV) SvIVX(sv)
#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)) {
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
mg_get(sv);
- if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNVX(sv))))
- return 0; /* So wrong but what can we do. */
-
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
SV * tmpstr;
UV value;
const char * const ptr =
isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
- const int numtype = grok_number(ptr, SvCUR(sv), &value);
-
- assert((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN)) == 0);
+ const int numtype
+ = grok_number(ptr, SvCUR(sv), &value);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
}
}
+ /* 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 (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
mg_get(sv);
- if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNVX(sv))))
- return 0; /* So wrong but what can we do. */
-
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
SV *tmpstr;
UV value;
const char * const ptr =
isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
- const int numtype = grok_number(ptr, SvCUR(sv), &value);
-
- assert((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN)) == 0);
+ const int numtype
+ = grok_number(ptr, SvCUR(sv), &value);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
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);
else
SvNOKp_on(sv);
#else
- if ((numtype & IS_NUMBER_INFINITY)) {
- SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
- SvNOK_on(sv);
- } else if ((numtype & IS_NUMBER_NAN)) {
- SvNV_set(sv, NV_NAN);
+ SvNV_set(sv, Atof(SvPVX_const(sv)));
+ /* Only set the public NV OK flag if this NV preserves the value in
+ the PV at least as well as an IV/UV would.
+ Not sure how to do this 100% reliably. */
+ /* if that shift count is out of range then Configure's test is
+ wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
+ UV_BITS */
+ if (((UV)1 << NV_PRESERVES_UV_BITS) >
+ U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+ SvNOK_on(sv); /* Definitely small enough to preserve all bits */
+ } else if (!(numtype & IS_NUMBER_IN_UV)) {
+ /* Can't use strtol etc to convert this string, so don't try.
+ sv_2iv and sv_2uv will use the NV to convert, not the PV. */
SvNOK_on(sv);
} else {
- SvNV_set(sv, Atof(SvPVX_const(sv)));
- /* Only set the public NV OK flag if this NV preserves the value in
- the PV at least as well as an IV/UV would.
- Not sure how to do this 100% reliably. */
- /* if that shift count is out of range then Configure's test is
- wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
- UV_BITS */
- if (((UV)1 << NV_PRESERVES_UV_BITS) >
- U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
- SvNOK_on(sv); /* Definitely small enough to preserve all bits */
- } else if (!(numtype & IS_NUMBER_IN_UV)) {
- /* Can't use strtol etc to convert this string, so don't try.
- sv_2iv and sv_2uv will use the NV to convert, not the PV. */
- SvNOK_on(sv);
+ /* value has been set. It may not be precise. */
+ if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
+ /* 2s complement assumption for (UV)IV_MIN */
+ SvNOK_on(sv); /* Integer is too negative. */
} else {
- /* value has been set. It may not be precise. */
- if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
- /* 2s complement assumption for (UV)IV_MIN */
- SvNOK_on(sv); /* Integer is too negative. */
- } else {
- SvNOKp_on(sv);
- SvIOKp_on(sv);
+ SvNOKp_on(sv);
+ SvIOKp_on(sv);
- if (numtype & IS_NUMBER_NEG) {
- SvIV_set(sv, -(IV)value);
- } else if (value <= (UV)IV_MAX) {
- SvIV_set(sv, (IV)value);
- } else {
- SvUV_set(sv, value);
- SvIsUV_on(sv);
- }
+ if (numtype & IS_NUMBER_NEG) {
+ SvIV_set(sv, -(IV)value);
+ } else if (value <= (UV)IV_MAX) {
+ SvIV_set(sv, (IV)value);
+ } else {
+ SvUV_set(sv, value);
+ SvIsUV_on(sv);
+ }
- if (numtype & IS_NUMBER_NOT_INT) {
- /* I believe that even if the original PV had decimals,
- they are lost beyond the limit of the FP precision.
- However, neither is canonical, so both only get p
- flags. NWC, 2000/11/25 */
- /* Both already have p flags, so do nothing */
- } else {
- const NV nv = SvNVX(sv);
- if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
- if (SvIVX(sv) == I_V(nv)) {
- SvNOK_on(sv);
- } else {
- /* It had no "." so it must be integer. */
- }
- SvIOK_on(sv);
+ if (numtype & IS_NUMBER_NOT_INT) {
+ /* I believe that even if the original PV had decimals,
+ they are lost beyond the limit of the FP precision.
+ However, neither is canonical, so both only get p
+ flags. NWC, 2000/11/25 */
+ /* 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);
} else {
- /* between IV_MAX and NV(UV_MAX).
- Could be slightly > UV_MAX */
+ /* It had no "." so it must be integer. */
+ }
+ SvIOK_on(sv);
+ } else {
+ /* between IV_MAX and NV(UV_MAX).
+ Could be slightly > UV_MAX */
- if (numtype & IS_NUMBER_NOT_INT) {
- /* UV and NV both imprecise. */
- } else {
- const UV nv_as_uv = U_V(nv);
+ if (numtype & IS_NUMBER_NOT_INT) {
+ /* UV and NV both imprecise. */
+ } else {
+ const UV nv_as_uv = U_V(nv);
- if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
- SvNOK_on(sv);
- }
- SvIOK_on(sv);
+ if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
+ SvNOK_on(sv);
}
+ SvIOK_on(sv);
}
}
}
}
- /* It might be more code efficient to go through the entire logic above
- and conditionally set with SvNOKp_on() rather than SvNOK(), but it
- gets complex and potentially buggy, so more programmer efficient
- to do it this way, by turning off the public flags: */
- if (!numtype)
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
}
+ /* It might be more code efficient to go through the entire logic above
+ and conditionally set with SvNOKp_on() rather than SvNOK(), but it
+ gets complex and potentially buggy, so more programmer efficient
+ to do it this way, by turning off the public flags: */
+ if (!numtype)
+ SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
#endif /* NV_PRESERVES_UV */
}
else {
- if (isGV_with_GP(sv)) {
- glob_2number(MUTABLE_GV(sv));
- return 0.0;
- }
+ if (isGV_with_GP(sv)) {
+ glob_2number(MUTABLE_GV(sv));
+ return 0.0;
+ }
- if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- assert (SvTYPE(sv) >= SVt_NV);
- /* Typically the caller expects that sv_any is not NULL now. */
- /* XXX Ilya implies that this is a bug in callers that assume this
- and ideally should be fixed. */
- return 0.0;
+ if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
+ assert (SvTYPE(sv) >= SVt_NV);
+ /* Typically the caller expects that sv_any is not NULL now. */
+ /* XXX Ilya implies that this is a bug in callers that assume this
+ and ideally should be fixed. */
+ return 0.0;
}
DEBUG_c({
- STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
- PTR2UV(sv), SvNVX(sv));
- RESTORE_NUMERIC_LOCAL();
- });
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
+ PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
+ PTR2UV(sv), SvNVX(sv));
+ RESTORE_NUMERIC_LOCAL();
+ });
return SvNVX(sv);
}
sv_upgrade(sv, SVt_PVNV);
if (SvNVX(sv) == 0.0
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- /* XXX Create SvNVXeq(sv, x)? Or just SvNVXzero(sv)? */
&& !Perl_isnan(SvNVX(sv))
#endif
) {
goto free_head;
}
- assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
+ /* objs are always >= MG, but pad names use the SVs_OBJECT flag
+ for another purpose */
+ assert(!SvOBJECT(sv) || type >= SVt_PVMG || SvPAD_NAME(sv));
if (type >= SVt_PVMG) {
- if (SvOBJECT(sv)) {
+ if (SvOBJECT(sv) && !SvPAD_NAME(sv)) {
if (!curse(sv, 1)) goto get_next_sv;
type = SvTYPE(sv); /* destructor may have changed it */
}
IoIFP(sv) != PerlIO_stderr() &&
!(IoFLAGS(sv) & IOf_FAKE_DIRP))
{
- io_close(MUTABLE_IO(sv), FALSE);
+ io_close(MUTABLE_IO(sv), NULL, FALSE,
+ (IoTYPE(sv) == IoTYPE_WRONLY ||
+ IoTYPE(sv) == IoTYPE_RDWR ||
+ IoTYPE(sv) == IoTYPE_APPEND));
}
if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
PerlDir_close(IoDIRP(sv));
sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
}
+#if DOUBLEKIND == DOUBLE_IS_IEEE_754_32_BIT_LITTLE_ENDIAN || \
+ DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_LITTLE_ENDIAN || \
+ DOUBLEKIND == DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
+# define DOUBLE_LITTLE_ENDIAN
+#endif
+
#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
/* The first double can be as large as 2**1023, or '1' x '0' x 1023.
* The second double can be as small as 2**-1074, or '0' x 1073 . '1'.
* The sum of them can be '1' . '0' x 2096 . '1', with implied radix point
- * after the first 1023 zero bits. */
+ * after the first 1023 zero bits.
+ *
+ * XXX The 2098 is quite large (262.25 bytes) and therefore some sort
+ * of dynamically growing buffer might be better, start at just 16 bytes
+ * (for example) and grow only when necessary. Or maybe just by looking
+ * at the exponents of the two doubles? */
# define DOUBLEDOUBLE_MAXBITS 2098
#endif
/* vhex will contain the values (0..15) of the hex digits ("nybbles"
* of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits
- * per xdigit. For the double-double case, this can be rather many. */
+ * per xdigit. For the double-double case, this can be rather many.
+ * The non-double-double-long-double overshoots since all bits of NV
+ * are not mantissa bits, there are also exponent bits. */
#ifdef LONGDOUBLE_DOUBLEDOUBLE
# define VHEX_SIZE (1+DOUBLEDOUBLE_MAXBITS/4)
#else
-# define VHEX_SIZE (1+128/4)
+# define VHEX_SIZE (1+(NVSIZE * 8)/4)
#endif
/* If we do not have a known long double format, (including not using
# 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)
+#if defined(DOUBLE_LITTLE_ENDIAN) || defined(LONGDOUBLE_LITTLE_ENDIAN)
# define HEXTRACT_LITTLE_ENDIAN
-#else
+#elif defined(DOUBLE_BIG_ENDIAN) || defined(LONGDOUBLE_BIG_ENDIAN)
# define HEXTRACT_BIG_ENDIAN
+#else
+# define HEXTRACT_MIX_ENDIAN
#endif
/* S_hextract() is a helper for Perl_sv_vcatpvfn_flags, for extracting
} STMT_END
#define HEXTRACT_BYTE(ix) \
STMT_START { \
- if (vend) HEXTRACT_OUTPUT(ix); else HEXTRACT_COUNT(ix, 2); \
+ 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) \
+ /* HEXTRACT_TOP_NYBBLE is just convenience disguise,
+ * to make it look less odd when the top bits of a NV
+ * are extracted using HEXTRACT_LO_NYBBLE: the highest
+ * order bits can be in the "low nybble" of a byte. */
+#define HEXTRACT_TOP_NYBBLE(ix) HEXTRACT_LO_NYBBLE(ix)
+#define HEXTRACT_BYTES_LE(a, b) \
+ for (ix = a; ix >= b; ix--) { HEXTRACT_BYTE(ix); }
+#define HEXTRACT_BYTES_BE(a, b) \
+ for (ix = a; ix <= b; ix++) { HEXTRACT_BYTE(ix); }
+#define HEXTRACT_IMPLICIT_BIT(nv) \
STMT_START { \
if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
} STMT_END
+/* Most formats do. Those which don't should undef this. */
+#define HEXTRACT_HAS_IMPLICIT_BIT
+/* Many formats do. Those which don't should undef this. */
+#define HEXTRACT_HAS_TOP_NYBBLE
+
/* HEXTRACTSIZE is the maximum number of xdigits. */
#if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE)
# define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/4)
# define HEXTRACTSIZE 2 * NVSIZE
#endif
- const U8* nvp = (const U8*)(&nv);
const U8* vmaxend = vhex + HEXTRACTSIZE;
+ PERL_UNUSED_VAR(ix); /* might happen */
(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
+ {
+ /* First check if using long doubles. */
+#if defined(USE_LONG_DOUBLE) && (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(nv);
- for (ix = 13; ix >= 0; ix--) {
- HEXTRACT_BYTE(ix);
- }
+ /* 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. */
+ const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_IMPLICIT_BIT(nv);
+# undef HEXTRACT_HAS_TOP_NYBBLE
+ HEXTRACT_BYTES_LE(13, 0);
# 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(nv);
- for (ix = 2; ix <= 15; ix++) {
- HEXTRACT_BYTE(ix);
- }
+ /* 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. */
+ const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_IMPLICIT_BIT(nv);
+# undef HEXTRACT_HAS_TOP_NYBBLE
+ HEXTRACT_BYTES_BE(2, 15);
# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
- /* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
- * significand, 15 bits of exponent, 1 bit of sign. NVSIZE can
- * 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 */
-
- /* Intentionally NO HEXTRACT_IMPLICIT_BIT here. */
- for (ix = 7; ix >= 0; ix--) {
- HEXTRACT_BYTE(ix);
- }
+ /* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
+ * significand, 15 bits of exponent, 1 bit of sign. NVSIZE can
+ * 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 */
+ const U8* nvp = (const U8*)(&nv);
+# undef HEXTRACT_HAS_IMPLICIT_BIT
+# undef HEXTRACT_HAS_TOP_NYBBLE
+ HEXTRACT_BYTES_LE(7, 0);
# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
- /* 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.
- *
- * 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 little-endian double-double is used .. somewhere?
- *
- * 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)
- */
-
- if (nv == (NV)0.0) {
- if (vend)
- *v++ = 0;
- else
- v++;
- *exponent = 0;
- }
- 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 {
+ /* 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.) */
+ const U8* nvp = (const U8*)(&nv);
+# undef HEXTRACT_HAS_IMPLICIT_BIT
+# undef HEXTRACT_HAS_TOP_NYBBLE
+ HEXTRACT_BYTES_BE(0, 7);
+# else
+# define HEXTRACT_FALLBACK
+ /* 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.
+ *
+ * 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 little-endian double-double is used .. somewhere?
+ *
+ * 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)
+ */
+# endif
+#else /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) */
+ /* 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 need to insert the radix. */
+# if NVSIZE == 8
+# ifdef HEXTRACT_LITTLE_ENDIAN
+ /* 0 1 2 3 4 5 6 7 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
+ const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_IMPLICIT_BIT(nv);
+ HEXTRACT_TOP_NYBBLE(6);
+ HEXTRACT_BYTES_LE(5, 0);
+# elif defined(HEXTRACT_BIG_ENDIAN)
+ /* 7 6 5 4 3 2 1 0 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
+ const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_IMPLICIT_BIT(nv);
+ HEXTRACT_TOP_NYBBLE(1);
+ HEXTRACT_BYTES_BE(2, 7);
+# elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE
+ /* 4 5 6 7 0 1 2 3 (MSB = 7, LSB = 0, 6:7 = nybble:exponent:sign) */
+ const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_IMPLICIT_BIT(nv);
+ HEXTRACT_TOP_NYBBLE(2); /* 6 */
+ HEXTRACT_BYTE(1); /* 5 */
+ HEXTRACT_BYTE(0); /* 4 */
+ HEXTRACT_BYTE(7); /* 3 */
+ HEXTRACT_BYTE(6); /* 2 */
+ HEXTRACT_BYTE(5); /* 1 */
+ HEXTRACT_BYTE(4); /* 0 */
+# elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE
+ /* 3 2 1 0 7 6 5 4 (MSB = 7, LSB = 0, 7:6 = sign:exponent:nybble) */
+ const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_IMPLICIT_BIT(nv);
+ HEXTRACT_TOP_NYBBLE(5); /* 6 */
+ HEXTRACT_BYTE(6); /* 5 */
+ HEXTRACT_BYTE(7); /* 4 */
+ HEXTRACT_BYTE(0); /* 3 */
+ HEXTRACT_BYTE(1); /* 2 */
+ HEXTRACT_BYTE(2); /* 1 */
+ HEXTRACT_BYTE(3); /* 0 */
+# else
+# define HEXTRACT_FALLBACK
+# endif
+# else
+# define HEXTRACT_FALLBACK
+# endif
+#endif /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) #else */
+# ifdef HEXTRACT_FALLBACK
+# undef HEXTRACT_HAS_TOP_NYBBLE /* Meaningless, but consistent. */
+ /* The fallback is used for the double-double format, and
+ * for unknown long double formats, and for unknown double
+ * formats, or in general unknown NV formats. */
+ if (nv == (NV)0.0) {
if (vend)
*v++ = 0;
else
v++;
+ *exponent = 0;
}
- e *= (NV)0.5;
+ 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 */
- /* Then extract the remaining hexdigits. */
- while (d > (NV)0.0) {
+ /* First extract the leading hexdigit (the implicit bit). */
if (d >= e) {
- ha |= hd;
d -= e;
+ if (vend)
+ *v++ = 1;
+ else
+ v++;
}
- if (hd == 1) {
- /* Output or count in groups of four bits,
- * that is, when the hexdigit is down to one. */
+ else {
if (vend)
- *v++ = ha;
+ *v++ = 0;
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++;
+ /* 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
- /* 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 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
- HEXTRACT_LO_NYBBLE(1);
- for (ix = 2; ix < NVSIZE; ix++) {
- HEXTRACT_BYTE(ix);
- }
-# 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
return;
}
-#ifndef USE_LONG_DOUBLE
+#if !defined(USE_LONG_DOUBLE) && !defined(USE_QUADMATH)
/* special-case "%.<number>[gf]" */
if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
&& (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && \
defined(PERL_PRIgldbl) && !defined(USE_QUADMATH)
long double fv;
-# define FV_ISFINITE(x) Perl_isfinitel(x)
+# ifdef Perl_isfinitel
+# define FV_ISFINITE(x) Perl_isfinitel(x)
+# endif
# define FV_GF PERL_PRIgldbl
# if defined(__VMS) && defined(__ia64) && defined(__IEEE_FLOAT)
/* Work around breakage in OTS$CVT_FLOAT_T_X */
# endif
#else
NV fv;
-# define FV_ISFINITE(x) Perl_isfinite((NV)(x))
# define FV_GF NVgf
# define NV_TO_FV(nv,fv) (fv)=(nv)
#endif
+#ifndef FV_ISFINITE
+# define FV_ISFINITE(x) Perl_isfinite((NV)(x))
+#endif
STRLEN have;
STRLEN need;
STRLEN gap;
*/
switch (intsize) {
case 'V':
-#if defined(USE_LONG_DOUBLE)
+#if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH)
intsize = 'q';
#endif
break;
case 'l':
/* FALLTHROUGH */
default:
-#if defined(USE_LONG_DOUBLE)
+#if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH)
intsize = args ? 0 : 'q';
#endif
break;
S_hextract(aTHX_ (NV)fv, &exponent, vhex, vend);
#if NVSIZE > DOUBLESIZE
-# ifdef LONGDOUBLE_X86_80_BIT
- exponent -= 4;
-# else
+# ifdef HEXTRACT_HAS_IMPLICIT_BIT
+ /* In this case there is an implicit bit,
+ * and therefore the exponent is shifted shift by one. */
exponent--;
+# else
+ /* In this case there is no implicit bit,
+ * and the exponent is shifted by the first xdigit. */
+ exponent -= 4;
# endif
#endif
char *ptr = ebuf + sizeof ebuf;
*--ptr = '\0';
*--ptr = c;
+#if defined(USE_QUADMATH)
+ if (intsize == 'q') {
+ /* "g" -> "Qg" */
+ *--ptr = 'Q';
+ }
/* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
-#if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
+#elif 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. */
/* Copy the one or more characters in a long double
* format before the 'base' ([efgEFG]) character to
* the format string. */
-#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) {
#endif
/* don't clone objects whose class has asked us not to */
- if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
+ if (SvOBJECT(sstr) && !SvPAD_NAME(sstr)
+ && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE))
+ {
SvFLAGS(dstr) = 0;
return dstr;
}
NOOP;
} else if (SvMAGIC(dstr))
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
- if (SvOBJECT(dstr) && SvSTASH(dstr))
+ if (SvOBJECT(dstr) && !SvPAD_NAME(dstr) && SvSTASH(dstr))
SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
else SvSTASH_set(dstr, 0); /* don't copy DESTROY cache */
}
? NULL
: gv_dup(CvGV(sstr), param);
- CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
+ if (!CvISXSUB(sstr)) {
+ PADLIST * padlist = CvPADLIST(sstr);
+ if(padlist)
+ padlist = padlist_dup(padlist, param);
+ CvPADLIST_set(dstr, padlist);
+ } else
+/* unthreaded perl can't sv_dup so we dont support unthreaded's CvHSCXT */
+ PoisonPADLIST(dstr);
+
CvOUTSIDE(dstr) =
CvWEAKOUTSIDE(sstr)
? cv_dup( CvOUTSIDE(dstr), param)
PL_incgv = gv_dup_inc(proto_perl->Iincgv, param);
PL_hintgv = gv_dup_inc(proto_perl->Ihintgv, param);
PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
+ PL_xsubfilename = proto_perl->Ixsubfilename;
PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
/* switches */
PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
- PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
PL_inplace = SAVEPV(proto_perl->Iinplace);
PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
/* index is constant */
SV* kidsv;
if (negate) {
- kidsv = sv_2mortal(newSVpvs("-"));
+ kidsv = newSVpvs_flags("-", SVs_TEMP);
sv_catsv(kidsv, cSVOPx_sv(kid));
}
else
case OP_SUBST:
case OP_MATCH:
if ( !(obase->op_flags & OPf_STACKED)) {
- if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
- ? PAD_SVl(obase->op_targ)
- : DEFSV))
- {
- sv = sv_newmortal();
- sv_setpvs(sv, "$_");
- return sv;
- }
+ if (uninit_sv == DEFSV)
+ return newSVpvs_flags("$_", SVs_TEMP);
+ else if (obase->op_targ
+ && uninit_sv == PAD_SVl(obase->op_targ))
+ return varname(NULL, '$', obase->op_targ, NULL, 0,
+ FUV_SUBSCRIPT_NONE);
}
goto do_op;
#define SVpad_OUR 0x00040000 /* pad name is "our" instead of "my" */
#define SVs_TEMP 0x00080000 /* mortal (implies string is stealable) */
#define SVs_OBJECT 0x00100000 /* is "blessed" */
+#define SVpad_LVALUE 0x00100000 /* pad name is used as lvalue */
#define SVs_GMG 0x00200000 /* has magical get method */
#define SVs_SMG 0x00400000 /* has magical set method */
#define SVs_RMG 0x00800000 /* has random magical methods */
HEK * xcv_hek; \
} xcv_gv_u; \
char * xcv_file; \
- PADLIST * xcv_padlist; \
+ union { \
+ PADLIST * xcv_padlist; \
+ void * xcv_hscxt; \
+ } xcv_padlist_u; \
CV * xcv_outside; \
U32 xcv_outside_seq; /* the COP sequence (at the point of our \
* compilation) in the lexically enclosing \
#define SvTAIL_on(sv) (SvFLAGS(sv) |= SVpbm_TAIL)
#define SvTAIL_off(sv) (SvFLAGS(sv) &= ~SVpbm_TAIL)
+#define SvPAD_NAME(sv) ((SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME)
#define SvPAD_TYPED(sv) \
((SvFLAGS(sv) & (SVpad_NAME|SVpad_TYPED)) == (SVpad_NAME|SVpad_TYPED))
d_archlib='define'
d_asctime64='undef'
d_asctime_r='undef'
+d_asinh='undef'
+d_atanh='undef'
d_atolf='undef'
d_atoll='undef'
d_attribute_deprecated='undef'
d_c99_variadic_macros='undef'
d_casti32='undef'
d_castneg='undef'
+d_cbrt='undef'
d_charvspr='undef'
d_chown='undef'
d_chroot='undef'
d_closedir='undef'
d_cmsghdr_s='undef'
d_const='define'
+d_copysign='undef'
d_copysignl='undef'
d_cplusplus='undef'
d_crypt='undef'
d_endsent='undef'
d_endservent_r='undef'
d_eofnblk='undef'
+d_erf='undef'
+d_erfc='undef'
d_eunice='undef'
+d_exp2='undef'
+d_expm1='undef'
d_faststdio='undef'
d_fchdir='undef'
d_fchmod='undef'
d_fcntl_can_lock='undef'
d_fd_macros='undef'
d_fd_set='undef'
+d_fdim='undef'
d_fds_bits='undef'
d_fegetround='undef'
d_fgetpos='undef'
d_flexfnam='define'
d_flock='undef'
d_flockproto='undef'
+d_fma='undef'
+d_fmax='undef'
+d_fmin='undef'
d_fork='undef'
d_fp_class='undef'
d_fp_classify='undef'
d_grpasswd='undef'
d_hasmntopt='undef'
d_htonl='define'
+d_hypot='undef'
+d_ilogb='undef'
d_ilogbl='undef'
d_inc_version_list='undef'
d_index='undef'
d_isinfl='undef'
d_isnan='undef'
d_isnanl='undef'
+d_isnormal='undef'
d_j0='undef'
d_j0l='undef'
d_killpg='undef'
d_lchown='undef'
d_ldbl_dig='undef'
d_ldexpl='undef'
+d_lgamma='undef'
+d_lgamma_r='undef'
d_libm_lib_version='undef'
d_link='undef'
+d_llrint='undef'
+d_llround='undef'
d_localtime64='undef'
d_localtime_r='undef'
d_localtime_r_needs_tzset='undef'
d_locconv='undef'
d_lockf='undef'
+d_log1p='undef'
+d_log2='undef'
+d_logb='undef'
d_longdbl='undef'
d_longlong='undef'
+d_lrint='undef'
+d_lround='undef'
d_lseekproto='undef'
d_lstat='undef'
d_madvise='undef'
d_msync='undef'
d_munmap='undef'
d_mymalloc='undef'
+d_nan='undef'
d_ndbm_h_uses_prototypes='undef'
+d_nearbyint='undef'
+d_nextafter='undef'
+d_nexttoward='undef'
d_nice='undef'
d_nl_langinfo='undef'
d_nv_preserves_uv='undef'
d_readlink='undef'
d_readv='undef'
d_recvmsg='undef'
+d_remainder='undef'
+d_remquo='undef'
d_rename='define'
d_rewinddir='define'
+d_rint='undef'
d_rmdir='define'
+d_round='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='undef'
d_sbrkproto='undef'
+d_scalbn='undef'
d_scalbnl='undef'
d_sched_yield='undef'
d_scm_rights='undef'
d_tcsetpgrp='undef'
d_telldir='define'
d_telldirproto='define'
+d_tgamma='undef'
d_time='define'
d_timegm='undef'
d_times='define'
d_tm_tm_gmtoff='undef'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
+d_trunc='undef'
d_truncate='undef'
d_truncl='undef'
d_ttyname_r='undef'
direntrytype='struct dirent'
dlext='dll'
dlsrc='dl_symbian.xs'
+doublekind='4'
doublesize='8'
drand01="((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15))"
drand48_r_proto='0'
Tests in the t/comp/, t/cmd/, t/run/, t/io/, t/op/ and t/uni/ directories
should also be runnable by miniperl and not require Config.pm, but
failures to comply will not cause TEST to abort like for t/base/.
+
+Tests in t/perf/ are designed to test performance and optimisations,
+and also contain additional tools and files designed to run outside
+of the test suite
# then comp, to validate that require works
# then run, to validate that -M works
# then we know we can -MTestInit for everything else, making life simpler
- foreach my $dir (qw(base comp run cmd io re opbasic op uni mro)) {
+ foreach my $dir (qw(base comp run cmd io re opbasic op uni mro perf)) {
_find_tests($dir);
}
unless ($::core) {
push @ARGV, _tests_from_manifest($extensions, $known_extensions);
unless ($::core) {
_find_tests('japh') if $::torture;
- _find_tests('t/benchmark') if $::benchmark or $ENV{PERL_BENCHMARK};
+ _find_tests('benchmark') if $::benchmark or $ENV{PERL_BENCHMARK};
_find_tests('bigmem') if $ENV{PERL_TEST_MEMORY};
}
}
#!./perl
-print "1..93\n";
+print "1..101\n";
$x = 'x';
(eval '${Function_with_side_effects,\$_}' || $@)
eq "sidekick function called";
print "ok $test - \${...} where {...} looks like hash\n"; $test++;
+
+@_ = map{BEGIN {$_122782 = 'tst2'}; "rhu$_"} 'barb2';
+print "not " unless "@_" eq 'rhubarb2';
+print "ok $test - map{BEGIN...\n"; $test++;
+print "not " unless $_122782 eq 'tst2';
+print "ok $test - map{BEGIN...\n"; $test++;
+${
+=pod
+blah blah blah
+=cut
+\$_ } = 42;
+print "not "unless $_ == 42;
+print "ok $test - \${ <newline> =pod\n"; $test++;
+@_ = map{
+=pod
+blah blah blah
+=cut
+$_+1 } 1;
+print "not "unless "@_" eq 2;
+print "ok $test - map{ <newline> =pod\n"; $test++;
+eval { ${...}++ };
+print "not " unless $@ =~ /^Unimplemented at /;
+print "ok $test - \${...} (literal triple-dot)\n"; $test++;
+eval { () = map{...} @_ };
+print "not " unless $@ =~ /^Unimplemented at /;
+print "ok $test - map{...} (literal triple-dot)\n"; $test++;
+print "not " unless &{sub :lvalue { "a" }} eq "a";
+print "ok $test - &{sub :lvalue...}\n"; $test++;
+print "not " unless ref +(map{sub :lvalue { "a" }} 1)[0] eq "CODE";
+print "ok $test - map{sub :lvalue...}\n"; $test++;
#!./perl
# Test $!
-print "1..48\n";
+print "1..38\n";
$test_count = 1;
$teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n";
binmode TESTFILE;
test_record(*TESTFILE);
close TESTFILE;
-test_bad_setting();
$test_count_end = $test_count; # Needed to know how many tests to skip
+test_bad_setting();
+
# Now for the tricky bit--full record reading
if ($^O eq 'VMS') {
# binary-incompatible previously-installed version. The eval won’t help in
# intercepting a SIGTRAP.
local @INC = ("../lib", "lib", @INC);
- if (not eval q/use PerlIO::scalar; use PerlIO::via::scalar; 1/) {
- # In-memory files necessitate PerlIO::via::scalar, thus a perl with
+ if (not eval q/use PerelIO::scalar; 1/) {
+ # In-memory files necessitate PerlIO::scalar, thus a perl with
# perlio and dynaloading enabled. miniperl won't be able to run this
# test, so skip it
- # PerlIO::via::scalar has to be tested as well.
- # use PerlIO::scalar succeeds with ./TEST and with ./perl harness but not with ./perl
-
for $test ($test_count .. $test_count + ($test_count_end - $test_count_start - 1)) {
print "ok $test # skipped - Can't test in memory file with miniperl/without PerlIO::Scalar\n";
$test_count++;
$test_count++;
# Naughty straight number - should get the rest of the file
- $/ = \0;
+ # no warnings 'deprecated'; # but not in t/base/*
+ { local $SIG{__WARN__} = sub {}; $/ = \0 }
$bar = <FH>;
if ($bar ne "90123456789012345678901234567890") {print "not ";}
print "ok $test_count # \$/ = \\0\n";
return $string if $::IS_ASCII;
my $output = "";
for my $i (0 .. length($string) - 1) {
- $output .= chr(ord_latin1_to_native(ord(substr($string, $i, 1))));
+ $output .= chr(utf8::unicode_to_native(ord(substr($string, $i, 1))));
}
# Preserve utf8ness of input onto the output, even if it didn't need to be
# utf8
chdir 't' if -d 't';
}
-print "1..170\n";
+print "1..171\n";
sub failed {
my ($got, $expected, $name) = @_;
like $@, qq/^Can't call method "method" on unblessed reference at /,
'method BLOCK {...} does not try to disambiguate';
+eval '#line 1 maggapom
+ if ($a>3) { $a ++; }
+ else {printf(1/0);}';
+is $@, "Illegal division by zero at maggapom line 2.\n",
+ 'else {foo} line number (no space after {) [perl #122695]';
+
# Add new tests HERE (above this line)
# bug #74022: Loop on characters in \p{OtherIDContinue}
unless (@tests) {
my @seq = <base/*.t>;
- my @next = qw(comp run cmd io re opbasic op uni mro lib porting);
+ my @next = qw(comp run cmd io re opbasic op uni mro lib porting perf);
push @next, 'japh' if $torture;
push @next, 'win32' if $^O eq 'MSWin32';
push @next, 'benchmark' if $ENV{PERL_BENCHMARK};
# make two handles that will always block
sub fresh_io {
+ close $in if $in; close $out if $out;
undef $in; undef $out; # use fresh handles each time
pipe $in, $out;
$sigst = "";
my $skip_mode_checks =
$^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/;
-plan tests => 55;
+plan tests => 61;
my $tmpdir = tempfile();
my $tmpdir1 = tempfile();
}
SKIP: {
- skip "no fchmod", 5 unless ($Config{d_fchmod} || "") eq "define";
+ skip "no fchmod", 7 unless ($Config{d_fchmod} || "") eq "define";
ok(open(my $fh, "<", "a"), "open a");
is(chmod(0, $fh), 1, "fchmod");
$mode = (stat "a")[2];
skip "no mode checks", 1 if $skip_mode_checks;
is($mode & 0777, $newmode, "perm restored");
}
+
+ # [perl #122703]
+ close $fh;
+ $! = 0;
+ ok(!chmod(0666, $fh), "chmod through closed handle fails");
+ isnt($!+0, 0, "and errno was set");
}
SKIP: {
- skip "no fchown", 1 unless ($Config{d_fchown} || "") eq "define";
+ skip "no fchown", 3 unless ($Config{d_fchown} || "") eq "define";
open(my $fh, "<", "a");
is(chown(-1, -1, $fh), 1, "fchown");
+
+ # [perl #122703]
+ # chown() behaved correctly, but there was no test for the chown()
+ # on closed handle case
+ close $fh;
+ $! = 0;
+ ok(!chown(-1, -1, $fh), "chown on closed handle fails");
+ isnt($!+0, 0, "and errno was set");
}
SKIP: {
isnt($mtime, 500000000 + $delta, 'mtime');
SKIP: {
- skip "no futimes", 4 unless ($Config{d_futimes} || "") eq "define";
+ skip "no futimes", 6 unless ($Config{d_futimes} || "") eq "define";
open(my $fh, "<", 'b');
$foo = (utime 500000000,500000000 + $delta, $fh);
is($foo, 1, "futime");
check_utime_result();
+ # [perl #122703]
+ close $fh;
+ ok(!utime(500000000,500000000 + $delta, $fh),
+ "utime fails on a closed file handle");
+ isnt($!+0, 0, "and errno was set");
}
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib' && -d '../ext';
+
+ require "./test.pl";
+ require Config; import Config;
+}
+
+use strict;
+use warnings;
+
+skip_all('no SysV semaphores on this platform') if !$Config{d_sem};
+
+my @warnings;
+{
+ local $SIG{__WARN__} = sub { push @warnings, $_[0] };
+ local $SIG{SYS} = sub { skip_all("SIGSYS caught") } if exists $SIG{SYS};
+ my $test = (semctl(-1,0,0,0))[0];
+ ok(!defined $test, "erroneous semctl list slice yields undef");
+}
+
+is(scalar @warnings, 0, "no warnings from erroneous semctl list slice")
+ or diag("warnings found: @warnings");
+
+done_testing;
__END__
+# NAME foo found where operator expected
+myfunc 1,2,3
+EXPECT
+Number found where operator expected at - line 1, near "myfunc 1"
+ (Do you need to predeclare myfunc?)
+syntax error at - line 1, near "myfunc 1"
+Execution of - aborted due to compilation errors.
+########
+# NAME foo found where operator expected (after strict error, w/fatal warnings)
+use warnings FATAL => 'all';
+use strict;
+$foo;
+myfunc 1,2,3
+EXPECT
+Global symbol "$foo" requires explicit package name (did you forget to declare "my $foo"?) at - line 3.
+Number found where operator expected at - line 4, near "myfunc 1"
+ (Do you need to predeclare myfunc?)
+syntax error at - line 4, near "myfunc 1"
+Execution of - aborted due to compilation errors.
+########
# NAME Unterminated here-doc in string eval
eval "<<foo"; die $@
EXPECT
EXPECT
Can't find string terminator "foo" anywhere before EOF at (eval 1) line 1.
########
+# NAME Unterminated here-doc in string
+"${<<foo"; # Used to give ‘Attempt to free blah blah blah’
+EXPECT
+Can't find string terminator "foo" anywhere before EOF at - line 1.
+########
# NAME Unterminated qw//
qw/
EXPECT
Missing right brace on \N{} or unescaped left brace after \N at - line 1, within pattern
Execution of - aborted due to compilation errors.
########
+# NAME map{for our *a...
+map{for our *a (1..10) {$_.=$x}}
+EXPECT
+Missing $ on loop variable at - line 1.
+########
# NAME Missing name in "my sub"
use feature 'lexical_subs'; my sub;
EXPECT
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
- plan( tests => 16 );
+ plan( tests => 17 );
}
for my $arg ('', 'q[]', qw( 1 undef )) {
eval { { my $x = ${qr//}; Internals::SvREADONLY $x, 1; () } };
is $@, "", 'read-only lexical regexps on scope exit [perl #115254]';
+
+Internals::SvREADONLY($],0);
+eval { $]=7 };
+is $], 7, 'SvREADONLY can make magic vars mutable'
undef $g1;
$m1 = '$g1';
$foo =~ s//$m1/ee;
+undef $m1;
+$m1 =~ tr/x/y/; undef $m1;
+$m1 =~ tr/x/y/r;
EXPECT
Use of my $_ is experimental at - line 16.
Use of uninitialized value $_ in pattern match (m//) at - line 5.
Use of uninitialized value $g1 in substitution iterator at - line 43.
Use of uninitialized value $m1 in substitution (s///) at - line 44.
Use of uninitialized value in substitution iterator at - line 47.
+Use of uninitialized value $m1 in transliteration (tr///) at - line 49.
+Use of uninitialized value $m1 in transliteration (tr///) at - line 50.
########
use warnings 'uninitialized';
my ($m1);
+++ /dev/null
-Test warnings related to $/
-__END__
--w
-# warnable code, warnings enabled via command line switch
-$/ = \0;
-EXPECT
-Setting $/ to a reference to zero as a form of slurp is deprecated, treating as undef at - line 3.
-########
--w
-# warnable code, warnings enabled via command line switch
-$/ = \-1;
-EXPECT
-Setting $/ to a reference to a negative integer as a form of slurp is deprecated, treating as undef at - line 3.
-
No such signal: SIG%s
$SIG{FRED} = sub {}
+ Setting $/ to a reference to zero as a form of slurp is deprecated, treating as undef
+
SIG%s handler \"%s\" not defined.
$SIG{"INT"} = "ok3"; kill "INT",$$;
- Mandatory Warnings TODO
- ------------------
- Can't break at that line [magic_setdbline]
-
__END__
# mg.c
use warnings 'signal' ;
EXPECT
########
+-w
+# warnable code, warnings enabled via command line switch
+$/ = \0;
+EXPECT
+Setting $/ to a reference to zero as a form of slurp is deprecated, treating as undef at - line 3.
+########
+-w
+# warnable code, warnings enabled via command line switch
+$/ = \-1;
+EXPECT
+Setting $/ to a reference to a negative integer as a form of slurp is deprecated, treating as undef at - line 3.
+########
+$/ = \-1;
+no warnings 'deprecated';
+$/ = \-1;
+EXPECT
+Setting $/ to a reference to a negative integer as a form of slurp is deprecated, treating as undef at - line 1.
+########
# mg.c
use warnings 'signal' ;
if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {
"diatrewq";
"igatrewq";
use 5.015;
-__SUB__ # OP_RUNCV
+__SUB__ ; # OP_RUNCV
+[]; # OP_ANONLIST
EXPECT
Useless use of a constant ("111") in void context at - line 2.
Useless use of repeat (x) in void context at - line 3.
Useless use of a constant ("diatrewq") in void context at - line 58.
Useless use of a constant ("igatrewq") in void context at - line 59.
Useless use of __SUB__ in void context at - line 61.
+Useless use of anonymous array ([]) in void context at - line 62.
########
# op.c
use warnings 'void' ; close STDIN ;
########
# op.c
#
-use warnings 'misc' ;
+use warnings 'misc' ; use utf8;
my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;my $d = 'test';
@a =~ /abc/ ;
@a2 =~ s/a/b/ ;
$d =~ tr/a/b/d ;
$d2 =~ tr/a/bc/;
$d3 =~ tr//b/c;
+$d =~ tr/α/β/d ;
+$d2 =~ tr/α/βγ/;
{
no warnings 'misc' ;
my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; my $d = 'test';
Applying transliteration (tr///) to %hash will act on scalar(%hash) at - line 16.
Useless use of /d modifier in transliteration operator at - line 17.
Replacement list is longer than search list at - line 18.
+Useless use of /d modifier in transliteration operator at - line 20.
+Replacement list is longer than search list at - line 21.
Can't modify array dereference in substitution (s///) at - line 6, near "s/a/b/ ;"
-BEGIN not safe after errors--compilation aborted at - line 21.
+BEGIN not safe after errors--compilation aborted at - line 23.
########
# op.c
use warnings 'parenthesis' ;
Use of bare << to mean <<"" is deprecated at - line 2.
########
# toke.c
+BEGIN {
+ if (ord('A') == 193) {
+ print "SKIPPED\n# Literal control characters in variable names forbidden on EBCDIC";
+ exit 0;
+ }
+}
eval "\$\cT";
eval "\${\7LOBAL_PHASE}";
eval "\${\cT}";
"\c`" is more clearly written simply as "\ " at - line 4.
########
# toke.c
+BEGIN {
+ if (ord('A') == 193) {
+ print "SKIPPED\n# test is ASCII-specific";
+ exit 0;
+ }
+}
+use warnings;
+my $a = "\c{ack}";
+EXPECT
+OPTION fatal
+Use ";" instead of "\c{" at - line 9.
+########
+# toke.c
+BEGIN {
+ if (ord('A') == 65) {
+ print "SKIPPED\n# test is EBCDIC-specific";
+ exit 0;
+ }
+}
use warnings;
my $a = "\c{ack}";
EXPECT
OPTION fatal
-Use ";" instead of "\c{" at - line 3.
+Sequence "\c{" invalid at - line 9.
########
# toke.c
my $a = "\câ";
########
# toke.c
#[perl #119123] disallow literal control character variables
+BEGIN {
+ if (ord('A') == 193) {
+ print "SKIPPED\n# Literal control characters in variable names forbidden on EBCDIC";
+ exit 0;
+ }
+}
eval "\$\cQ = 25";
eval "\${ \cX } = 24";
*{
use warnings 'utf8';
my $d800 = uc(chr(0xD800));
my $nonUnicode = uc(chr(0x110000));
-my $big_nonUnicode = uc(chr(0x8000_0000));
no warnings 'non_unicode';
my $d800 = uc(chr(0xD800));
my $nonUnicode = uc(chr(0x110000));
-my $big_nonUnicode = uc(chr(0x8000_0000));
EXPECT
Operation "uc" returns its argument for UTF-16 surrogate U+D800 at - line 2.
Operation "uc" returns its argument for non-Unicode code point 0x110000 at - line 3.
-Operation "uc" returns its argument for non-Unicode code point 0x80000000 at - line 4.
-Operation "uc" returns its argument for UTF-16 surrogate U+D800 at - line 6.
+Operation "uc" returns its argument for UTF-16 surrogate U+D800 at - line 5.
+########
+BEGIN {
+ if (ord('A') == 193) {
+ print "SKIPPED\n# ebcdic platforms can't handle this large a code point";
+ exit 0;
+ }
+}
+use warnings 'utf8';
+my $big_nonUnicode = uc(chr(0x8000_0000));
+no warnings 'non_unicode';
+my $big_nonUnicode = uc(chr(0x8000_0000));
+EXPECT
+Operation "uc" returns its argument for non-Unicode code point 0x80000000 at - line 8.
########
use warnings 'utf8';
my $d7ff = lc pack("U", 0xD7FF);
print $fh "\x{110000}", "\n";
close $fh;
EXPECT
+########
+# NAME Case change crosses 255/256 under non-UTF8 locale
+eval { require POSIX; POSIX->import("locale_h") };
+if ($@) {
+ print("SKIPPED\n# no POSIX\n"),exit;
+}
+use warnings 'locale';
+use feature 'fc';
+use locale;
+setlocale(&POSIX::LC_CTYPE, "C");
+my $a;
+$a = lc("\x{178}");
+$a = fc("\x{1E9E}");
+$a = fc("\x{FB05}");
+$a = uc("\x{FB00}");
+$a = ucfirst("\x{149}");
+EXPECT
+Can't do lc("\x{178}") on non-UTF-8 locale; resolved to "\x{178}". at - line 10.
+Can't do fc("\x{1E9E}") on non-UTF-8 locale; resolved to "\x{17F}\x{17F}". at - line 11.
+Can't do fc("\x{FB05}") on non-UTF-8 locale; resolved to "\x{FB06}". at - line 12.
+Can't do uc("\x{FB00}") on non-UTF-8 locale; resolved to "\x{FB00}". at - line 13.
+Can't do ucfirst("\x{149}") on non-UTF-8 locale; resolved to "\x{149}". at - line 14.
# anyway later during the scanning process (and besides, some clueless
# vendor might have them capitalized erroneously anyway).
+# Some of the locales on the system may not play well with Perl. Since, we
+# may be trying every possible locale, we don't want to be warned about the
+# weird ones.
+no warnings 'locale';
+
sub _trylocale { # Adds the locale given by the first parameter to the list
# given by the 3rd iff the platform supports the locale in
# each of the categories given by the 2nd parameter, which
push @enc, "$_.65001"; # Windows UTF-8
push @enc, "$_.ACP"; # Windows ANSI code page
push @enc, "$_.OCP"; # Windows OEM code page
+ push @enc, "$_.1252"; # Windows
}
}
if ($^O eq 'os390') {
# system. The parameter is either a single locale
# category or a reference to a list of categories to
# find valid locales for it (or in the case of
- # multiple) for all of them
+ # multiple) for all of them. Note that currently the
+ # array includes even those locales that don't play
+ # well with Perl
my $categories = shift;
use Config;;
# This is going to be slow.
my @Data;
-
# Locales whose name differs if the utf8 bit is on are stored in these two
# files with appropriate encodings.
if ($^H & 0x08 || (${^OPEN} || "") =~ /:utf8/) {
@Locale = sort @Locale;
return @Locale;
-
-
}
sub is_locale_utf8 ($) { # Return a boolean as to if core Perl thinks the input
# is a UTF-8 locale
+
+ # On z/OS, even locales marked as UTF-8 aren't.
+ return 0 if ord "A" != 65;
+
my $locale = shift;
use locale;
return $ret;
}
-sub find_utf8_ctype_locale (;$) { # Return the name of locale that core Perl
+sub find_utf8_ctype_locale (;$) { # Return the name of a locale that core Perl
# thinks is a UTF-8 LC_CTYPE locale.
# Optional parameter is a reference to a
# list of locales to try; if omitted, this
#!./perl
-use strict;
-use warnings;
-
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require q(./test.pl);
}
+
+use strict;
+use warnings;
+
plan(tests => 61);
require mro;
#!./perl
-use strict;
-use warnings;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
}
}
+use strict;
+use warnings;
+
require q(./test.pl); plan(tests => 1);
require mro;
#!./perl
-use strict;
-use warnings;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
}
}
+use strict;
+use warnings;
+
use utf8;
use open qw( :utf8 :std );
#!./perl
-use strict;
-no strict 'refs'; # we do a lot of this
-use warnings;
-no warnings 'redefine'; # we do a lot of this
-no warnings 'prototype'; # we do a lot of this
-
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
require './test.pl';
}
+use strict;
+no strict 'refs'; # we do a lot of this
+use warnings;
+no warnings 'redefine'; # we do a lot of this
+no warnings 'prototype'; # we do a lot of this
+
{
package MCTest::Base;
sub foo { return $_[1]+1 };
#!./perl
-use utf8;
-use open qw( :utf8 :std );
-use strict;
-use warnings;
-no warnings 'redefine'; # we do a lot of this
-no warnings 'prototype'; # we do a lot of this
-
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
}
}
+use utf8;
+use open qw( :utf8 :std );
+use strict;
+use warnings;
+no warnings 'redefine'; # we do a lot of this
+no warnings 'prototype'; # we do a lot of this
+
require './test.pl';
{
#!./perl
-use strict;
-use warnings;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
require './test.pl';
+use strict;
+use warnings;
+
plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM};
plan(tests => 8);
#!./perl
-use strict;
-use warnings;
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
}
}
+use strict;
+use warnings;
+
require './test.pl';
plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM};
# The repetition number must be set to the value of $BYTES in
# lib/warnings.pm
- BEGIN { check_bits( ${^WARNING_BITS}, "\0" x 16, 'all bits off via "no warnings"' ) }
- testwarn("\0" x 16, 'no bits');
+ BEGIN { check_bits( ${^WARNING_BITS}, "\0" x 17, 'all bits off via "no warnings"' ) }
+ testwarn("\0" x 17, 'no bits');
use warnings;
BEGIN { check_bits( ${^WARNING_BITS}, $default,
require './test.pl'; require './charset_tools.pl';
}
-plan tests => 143;
+plan tests => 148;
$_ = 'abc';
$c = foo();
is($result, "\x{fffffffffffffffe}", "chop even higher 'unicode' - result");
}
}
+
+$/ = "\n";
+{
+ my $expected = 99999;
+ my $input = "UserID\talpha $expected\n";
+ my $uid = '';
+ chomp(my @line = split (/ |\t/,$input));
+ $uid = $line[-1];
+ is($uid, $expected,
+ "RT #123057: chomp works as expected on split");
+}
+
+{
+ my $a = local $/ = 7;
+ $a = chomp $a;
+ is $a, 1, 'lexical $a = chomp $a when $a eq $/ eq 7';
+ $a = $/ = 0;
+ $a = chomp $a;
+ is $a, 1, 'lexical $a = chomp $a when $a eq $/ eq 0';
+ my @a = "7";
+ for my $b($a[0]) {
+ $/ = 7;
+ $b = chomp @a;
+ is $b, 1,
+ 'lexical $b = chomp @a when $b eq $/ eq 7 and \$a[0] == \$b';
+ $b = $/ = 0;
+ $b = chomp @a;
+ is $b, 1,
+ 'lexical $b = chomp @a when $b eq $/ eq 0 and \$a[0] == \$b';
+ }
+}
"don't copy a stale lexical; create a fresh undef one instead");
}
-# [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant
-
-BEGIN {
- my $x = 7;
- *baz = sub() { if($x){ () = "tralala"; blonk() }; 0 }
-}
-{
- my $blonk_was_called;
- *blonk = sub { ++$blonk_was_called };
- my $ret = baz();
- is($ret, 0, 'RT #63540');
- is($blonk_was_called, 1, 'RT #63540');
-}
-
# test PL_cv_has_eval. Any anon sub that could conceivably contain an
# eval, should be marked as cloneable
'closures in source filters do not interfere with pad names';
}
+sub {
+ my $f;
+ sub test_ref_to_unavailable {
+ my $ref = \$f;
+ $$ref = 7;
+ is $f, 7, 'taking a ref to unavailable var should not copy it';
+ }
+};
+test_ref_to_unavailable();
+
done_testing();
--- /dev/null
+#!perl
+
+# Test the various op trees that turn sub () { ... } into a constant, and
+# some variants that don’t.
+
+BEGIN {
+ chdir 't';
+ require './test.pl';
+ @INC = '../lib';
+}
+plan 168;
+
+# @tests is an array of hash refs, each of which can have various keys:
+#
+# nickname - name of the sub to use in test names
+# generator - a sub returning a code ref to test
+# finally - sub to run after the tests
+#
+# Each of the following gives expected test results. If the key is
+# omitted, the test is skipped:
+#
+# retval - the returned code ref’s return value
+# same_retval - whether the same scalar is returned each time
+# inlinable - whether the sub is inlinable
+# deprecated - whether the sub returning a code ref will emit a depreca-
+# tion warning when called
+# method - whether the sub has the :method attribute
+
+# [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant
+sub blonk { ++$blonk_was_called }
+push @tests, {
+ nickname => 'sub with null+kids (if-block), then constant',
+ generator => sub {
+ # This used to turn into a constant with the value of $x
+ my $x = 7;
+ sub() { if($x){ () = "tralala"; blonk() }; 0 }
+ },
+ retval => 0,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+ finally => sub { ok($blonk_was_called, 'RT #63540'); },
+};
+
+# [perl #79908]
+push @tests, {
+ nickname => 'sub with simple lexical modified elsewhere',
+ generator => sub { my $x = 5; my $ret = sub(){$x}; $x = 7; $ret },
+ retval => 5, # change to 7 when the deprecation cycle is over
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 1,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'sub with simple lexical unmodified elsewhere',
+ generator => sub { my $x = 5; sub(){$x} },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'return $variable modified elsewhere',
+ generator => sub { my $x=5; my $ret = sub(){return $x}; $x = 7; $ret },
+ retval => 7,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'return $variable unmodified elsewhere',
+ generator => sub { my $x = 5; sub(){return $x} },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'sub () { 0; $x } with $x modified elsewhere',
+ generator => sub { my $x = 5; my $ret = sub(){0;$x}; $x = 8; $ret },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'sub () { 0; $x } with $x unmodified elsewhere',
+ generator => sub { my $x = 5; my $y = $x; sub(){0;$x} },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+
+# Explicit return after optimised statement, not at end of sub
+push @tests, {
+ nickname => 'sub () { 0; return $x; ... }',
+ generator => sub { my $x = 5; sub () { 0; return $x; ... } },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+# Explicit return after optimised statement, at end of sub [perl #123092]
+push @tests, {
+ nickname => 'sub () { 0; return $x }',
+ generator => sub { my $x = 5; sub () { 0; return $x } },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+# Multiple closure tests
+push @tests, {
+ nickname => 'simple lexical after another closure and no lvalue',
+ generator => sub {
+ my $x = 5;
+ # This closure prevents inlining, though theoretically it shouldn’t
+ # have to. If you change the behaviour, just change the test. This
+ # fails the refcount check in op.c:op_const_sv, which is necessary for
+ # the sake of \(my $x = 1) (tested below).
+ my $sub1 = sub () { () = $x };
+ sub () { $x };
+ },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'simple lexical before another closure and no lvalue',
+ generator => sub {
+ my $x = 5;
+ my $ret = sub () { $x };
+ # This does not prevent inlining and never has.
+ my $sub1 = sub () { () = $x };
+ $ret;
+ },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'simple lexical after an lvalue closure',
+ generator => sub {
+ my $x = 5;
+ # This has always prevented inlining
+ my $sub1 = sub () { $x++ };
+ sub () { $x };
+ },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'simple lexical before an lvalue closure',
+ generator => sub {
+ my $x = 5;
+ my $ret = sub () { $x }; # <-- simple lexical op tree
+ # Traditionally this has not prevented inlining, though it should. But
+ # since $ret has a simple lexical op tree, we preserve backward-compat-
+ # ibility, but deprecate it.
+ my $sub1 = sub () { $x++ };
+ $ret;
+ },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 1,
+ method => 0,
+};
+push @tests, {
+ nickname => 'complex lexical op tree before an lvalue closure',
+ generator => sub {
+ my $x = 5;
+ my $ret = sub () { 0; $x }; # <-- more than just a lexical
+ # This used not to prevent inlining, though it should, and now does.
+ my $sub1 = sub () { $x++ };
+ $ret;
+ },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'complex lexical op tree before a nested lvalue closure',
+ generator => sub {
+ my $x = 5;
+ my $ret = sub () { 0; $x }; # <-- more than just a lexical
+ # This used not to prevent inlining, though it should, and now does.
+ my $sub1 = sub () { sub () { $x++ } }; # nested
+ $ret;
+ },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+use feature 'state', 'lexical_subs';
+no warnings 'experimental::lexical_subs';
+
+# Constant constants
+push @tests, {
+ nickname => 'sub with constant',
+ generator => sub { sub () { 8 } },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'sub with constant and return',
+ generator => sub { sub () { return 8 } },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'sub with optimised statement and constant',
+ generator => sub { sub () { 0; 8 } },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'sub with optimised statement, constant and return',
+ generator => sub { sub () { 0; return 8 } },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'my sub with constant',
+ generator => sub { my sub x () { 8 } \&x },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'my sub with constant and return',
+ generator => sub { my sub x () { return 8 } \&x },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'my sub with optimised statement and constant',
+ generator => sub { my sub x () { 0; 8 } \&x },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'my sub with optimised statement, constant and return',
+ generator => sub { my sub x () { 0; return 8 } \&x },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+# String eval
+push @tests, {
+ nickname => 'sub () { $x } with eval in scope',
+ generator => sub {
+ my $outer = 43;
+ my $ret = sub () { $outer };
+ eval '$outer++';
+ $ret;
+ },
+ retval => 43,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 1,
+ method => 0,
+};
+push @tests, {
+ nickname => 'sub () { $x } with s///ee in scope',
+ generator => sub {
+ my $outer = 43;
+ my $dummy = '$outer++';
+ my $ret = sub () { $outer };
+ $dummy =~ s//$dummy/ee;
+ $ret;
+ },
+ retval => 43,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 1,
+ method => 0,
+};
+push @tests, {
+ nickname => 'sub () { $x } with eval not in scope',
+ generator => sub {
+ my $ret;
+ {
+ my $outer = 43;
+ $ret = sub () { $outer };
+ }
+ eval '';
+ $ret;
+ },
+ retval => 43,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'sub () { my $x; state sub z { $x } $outer }',
+ generator => sub {
+ my $outer = 43;
+ sub () { my $x; state sub z { $x } $outer }
+ },
+ retval => 43,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'closure after \(my $x=1)',
+ generator => sub {
+ $y = \(my $x = 1);
+ my $ret = sub () { $x };
+ $$y += 7;
+ $ret;
+ },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'sub:method with simple lexical',
+ generator => sub { my $y; sub():method{$y} },
+ retval => undef,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 1,
+};
+push @tests, {
+ nickname => 'sub:method with constant',
+ generator => sub { sub():method{3} },
+ retval => 3,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 1,
+};
+push @tests, {
+ nickname => 'my sub:method with constant',
+ generator => sub { my sub x ():method{3} \&x },
+ retval => 3,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 1,
+};
+
+push @tests, {
+ nickname => 'sub closing over state var',
+ generator => sub { state $x = 3; sub () {$x} },
+ retval => 3,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'sub closing over state var++',
+ generator => sub { state $x++; sub () { $x } },
+ retval => 1,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 1,
+ method => 0,
+};
+
+
+use feature 'refaliasing';
+no warnings 'experimental::refaliasing';
+for \%_ (@tests) {
+ my $nickname = $_{nickname};
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ my $sub = &{$_{generator}};
+ if (exists $_{deprecated}) {
+ if ($_{deprecated}) {
+ like $w, qr/^Constants from lexical variables potentially (?x:
+ )modified elsewhere are deprecated at /,
+ "$nickname is deprecated";
+ }
+ else {
+ is $w, undef, "$nickname is not deprecated";
+ }
+ }
+ if (exists $_{retval}) {
+ is &$sub, $_{retval}, "retval of $nickname";
+ }
+ if (exists $_{same_retval}) {
+ my $same = $_{same_retval} ? "same" : "different";
+ &{$_{same_retval} ? \&is : \&isnt}(
+ \scalar &$sub(), \scalar &$sub(),
+ "$nickname gives $same retval each call"
+ );
+ }
+ if (exists $_{inlinable}) {
+ local *temp_inlinability_test = $sub;
+ $w = undef;
+ use warnings 'redefine';
+ *temp_inlinability_test = sub (){};
+ my $S = $_{inlinable} ? "Constant s" : "S";
+ my $not = " not" x! $_{inlinable};
+ like $w, qr/^${S}ubroutine .* redefined at /,
+ "$nickname is$not inlinable";
+ }
+ if (exists $_{method}) {
+ local *time = $sub;
+ $w = undef;
+ use warnings 'ambiguous';
+ eval "()=time";
+ if ($_{method}) {
+ is $w, undef, "$nickname has :method attribute";
+ }
+ else {
+ like $w, qr/^Ambiguous call resolved as CORE::time\(\), (?x:
+ )qualify as such or use & at /,
+ "$nickname has no :method attribute";
+ }
+ }
+
+ &{$_{finally} or next}
+}
+
+# This used to fail an assertion in leave_scope. For some reason, it did
+# not fail within the framework above.
+sub { my $x = "x"; my $sub = sub () { $x }; undef $sub; } ->();
+pass("No assertion failure when turning on PADSTALE on lexical shared by"
+ ." erstwhile constant");
+
+{
+ my $sub = sub {
+ my $x = "x"x2000; sub () {$x};
+ }->();
+ $y = &$sub;
+ $z = &$sub;
+ is $z, $y, 'inlinable sub ret vals are not swipable';
+}
skip_all("crypt unimplemented");
}
else {
- plan(tests => 4);
+ plan(tests => 6);
}
}
is($@, '', "downgrade to eight bit characters");
is($b, crypt("a\xFF", $alg."cd"), "downgrade results agree");
+my $x = chr 256; # has to be lexical, and predeclared
+# Assignment gets optimised away here:
+$x = crypt "foo", ${\"bar"}; # ${\ } to defeat constant folding
+is $x, crypt("foo", "bar"), 'crypt writing to utf8 target';
+ok !utf8::is_utf8($x), 'crypt turns off utf8 on its target';
chdir 't' if -d 't';
@INC = qw(../lib);
require './test.pl';
- plan (tests => 17);
+ plan (tests => 22);
}
is __SUB__, "__SUB__", '__SUB__ is a bareword outside of use feature';
} 1;
}
squag();
+
+sub f () { __SUB__ }
+is f, \&f, 'sub named () { __SUB__ } returns self ref';
+my $f = sub () { __SUB__ };
+is &$f, $f, 'anonymous sub(){__SUB__} returns self ref';
+my $f2 = sub () { $f++ if 0; __SUB__ };
+is &$f2, $f2, 'sub(){__SUB__} anonymous closure returns self ref';
+$f = sub () { eval ""; __SUB__ };
+is &$f, $f, 'anonymous sub(){eval ""; __SUB__} returns self ref';
+{
+ local $ENV{PERL5DB} = 'sub DB::DB {}';
+ is runperl(
+ switches => [ '-d' ],
+ prog => '$f = sub(){CORE::__SUB__}; print qq-ok\n- if $f == &$f;',
+ ),
+ "ok\n",
+ 'sub(){__SUB__} under -d';
+}
+
require './test.pl';
}
-plan tests => 57;
+plan tests => 59;
$h{'abc'} = 'ABC';
$h{'def'} = 'DEF';
}
ok(!$warned, "no warnings 'internal' silences each() after insert warnings");
}
+
+use feature 'refaliasing';
+no warnings 'experimental::refaliasing';
+$a = 7;
+\$h2{f} = \$a;
+($a, $b) = (each %h2);
+is "$a $b", "f 7", 'each in list assignment';
+$a = 7;
+($a, $b) = (3, values %h2);
+is "$a $b", "3 7", 'values in list assignment';
use warnings;
use vars qw(@array @r $k $v $c);
-plan tests => 63;
+plan tests => 65;
@array = qw(crunch zam bloop);
# Explicit reset
while (each @array) { }
}
+
+my $a = 7;
+*a = sub { \@_ }->($a);
+($a, $b) = each our @a;
+is "$a $b", "0 7", 'each in list assignment';
+$a = 7;
+($a, $b) = (3, values @a);
+is "$a $b", "3 7", 'values in list assignment';
require "./test.pl";
}
-plan(12);
+plan(13);
@a = (1,2,3,4,5,6,7,8,9,10,11,12);
@b = ();
push @_, \scalar(0..0) for 1,2;
isnt $_[0], $_[1], '\scalar($a..$b) gives a different scalar each time';
+
+# This evil little example from ticket #122829 abused the fact that each
+# recursion level maintained its own flip-flip state. The following com-
+# ment describes how it *used* to work.
+
+# This routine maintains multiple flip-flop states, each with its own
+# numeric ID, starting from 1. Pass the ID as the argument.
+sub f {
+ my $depth = shift() - 1;
+ return f($depth) if $depth;
+ return /3/../5/;
+}
+{
+ my $accumulator;
+ for(1..20) {
+ if (f(1)) {
+ my $outer = $_;
+ for(1..10){
+ $accumulator .= "$outer $_\n" if f(2);
+ }
+ }
+ }
+ is $accumulator, <<EOT, 'recursion shares state';
+3 1
+3 2
+3 3
+3 4
+3 5
+13 1
+13 2
+13 3
+13 4
+13 5
+EOT
+}
#!./perl
-use strict;
-
-use Config;
-
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
+use strict;
+
+use Config;
+
plan(tests => 79);
# Test hexfloat literals.
SKIP: {
if ($Config{uselongdouble} &&
- ($Config{longdblkind} == 6 || $Config{longdoublekind} == 5)) {
+ ($Config{longdblkind} == 6 || $Config{longdblkind} == 5)) {
skip "the double-double format is weird", 1;
}
}
}
+# *Do* use pad TARG if it is actually a named variable, even when the thing
+# you’re copying is a ref. The fix for #9466 broke this.
+{
+ package P9466_2;
+ my $x;
+ sub DESTROY { $x = 1 }
+ for (2..3) {
+ $x = 0;
+ my $a = bless {};
+ my $b;
+ use integer;
+ if ($_ == 2) {
+ $b = $a--; # sassign optimised away
+ }
+ else {
+ $b = $a++;
+ }
+ ::is(ref $b, __PACKAGE__, 'i_post(in|de)c/TARGMY on ref');
+ undef $a; undef $b;
+ ::is($x, 1, "9466 case $_");
+ }
+}
+
$_ = ${qr //};
$_--;
is($_, -1, 'regexp--');
$_++;
isnt(ref\$_, 'VSTRING', '++ flattens vstrings');
+sub TIESCALAR {bless\my $x}
+sub STORE { ++$store::called }
+tie my $t, "";
+{
+ $t = $_++;
+ $t = $_--;
+ use integer;
+ $t = $_++;
+ $t = $_--;
+}
+is $store::called, 4, 'STORE called on "my" target';
+
+{
+ # Temporarily broken between before 5.6.0 (b162f9ea/21f5b33c) and
+ # between 5.21.5 and 5.21.6 (9e319cc4fd)
+ my $x = 7;
+ $x = $x++;
+ is $x, 7, '$lex = $lex++';
+ $x = 7;
+ # broken in b162f9ea (5.6.0); fixed in 5.21.6
+ use integer;
+ $x = $x++;
+ is $x, 7, '$lex = $lex++ under use integer';
+}
+
done_testing();
{
my $search;
my $text;
- $search = latin1_to_native("foo \xc9 bar");
- $text = latin1_to_native("a\xa3\xa3a $search $search quux");
+ $search = "foo " . latin1_to_native("\xc9") . " bar";
+ $text = "a" . latin1_to_native("\xa3\xa3") . "a $search $search quux";
my $text_utf8 = $text;
utf8::upgrade($text_utf8);
}
SKIP: {
- skip "UTF-EBCDIC is limited to 0x7fffffff", 3 if ord("A") == 193;
+ skip "UTF-EBCDIC is limited to 0x7fffffff", 3 if $::IS_EBCDIC;
- my $a = "\x{80000000}";
+ my $a = eval q{"\x{80000000}"};
my $s = $a.'defxyz';
is(index($s, 'def'), 1, "0x80000000 is a single character");
- my $b = "\x{fffffffd}";
+ my $b = eval q{"\x{fffffffd}"};
my $t = $b.'pqrxyz';
is(index($t, 'pqr'), 1, "0xfffffffd is a single character");
push @packi_fmt, qw(q Q);
}
-if ($Config{uselongdouble}) {
+if ($Config{uselongdouble} && $Config{nvsize} > $Config{doublesize}) {
push @packf_fmt, 'D';
}
cmp_ok($PInf * 2, '==', $PInf, "twice Inf is Inf");
cmp_ok($PInf / 2, '==', $PInf, "half of Inf is Inf");
-cmp_ok($PInf * $PInf, '==', $PInf, "-Inf * +Inf is +Inf");
+cmp_ok($PInf * $PInf, '==', $PInf, "+Inf * +Inf is +Inf");
+cmp_ok($PInf * $NInf, '==', $NInf, "+Inf * -Inf is -Inf");
+cmp_ok($NInf * $PInf, '==', $NInf, "-Inf * +Inf is -Inf");
cmp_ok($NInf * $NInf, '==', $PInf, "-Inf * -Inf is +Inf");
is(sprintf("%g", $PInf), "Inf", "$PInf sprintf %g is Inf");
like($@, qr/Cannot chr/, "stringy -Inf chr() fails");
for my $f (@packi_fmt) {
+ undef $a;
ok(!defined eval { $a = pack($f, $PInf) }, "pack $f +Inf undef");
like($@, $f eq 'w' ? qr/Cannot compress Inf/: qr/Cannot pack Inf/,
"+Inf pack $f fails");
+ undef $a;
ok(!defined eval { $a = pack($f, "Inf") },
"pack $f stringy +Inf undef");
like($@, $f eq 'w' ? qr/Cannot compress Inf/: qr/Cannot pack Inf/,
"stringy +Inf pack $f fails");
+ undef $a;
ok(!defined eval { $a = pack($f, $NInf) }, "pack $f -Inf undef");
like($@, $f eq 'w' ? qr/Cannot compress -Inf/: qr/Cannot pack -Inf/,
"-Inf pack $f fails");
+ undef $a;
ok(!defined eval { $a = pack($f, "-Inf") },
"pack $f stringy -Inf undef");
like($@, $f eq 'w' ? qr/Cannot compress -Inf/: qr/Cannot pack -Inf/,
}
for my $f (@packf_fmt) {
+ undef $a;
+ undef $b;
ok(defined eval { $a = pack($f, $PInf) }, "pack $f +Inf defined");
eval { $b = unpack($f, $a) };
cmp_ok($b, '==', $PInf, "pack $f +Inf equals $PInf");
+ undef $a;
+ undef $b;
ok(defined eval { $a = pack($f, $NInf) }, "pack $f -Inf defined");
eval { $b = unpack($f, $a) };
cmp_ok($b, '==', $NInf, "pack $f -Inf equals $NInf");
}
for my $f (@packs_fmt) {
+ undef $a;
ok(defined eval { $a = pack($f, $PInf) }, "pack $f +Inf defined");
is($a, pack($f, "Inf"), "pack $f +Inf same as 'Inf'");
+ undef $a;
ok(defined eval { $a = pack($f, $NInf) }, "pack $f -Inf defined");
is($a, pack($f, "-Inf"), "pack $f -Inf same as 'Inf'");
}
is(sin(9**9**9), $NaN, "sin(9**9**9) is NaN");
}
+SKIP: {
+ my @FNaN = qw(NaX XNAN Ind Inx);
+ # Silence "isn't numeric in addition", that's kind of the point.
+ local $^W = 0;
+ for my $i (@FNaN) {
+ cmp_ok("$i" + 0, '==', 0, "false nan $i");
+ }
+}
+
# === Tests combining Inf and NaN ===
# is() okay with $NaN because it uses eq.
require './test.pl';
}
-plan tests => 26;
+plan tests => 28;
@x = (1, 2, 3);
is( join(':',@x), '1:2:3', 'join an array with character');
is( $ju2, $u );
}
+package o { use overload q|""| => sub { ${$_[0]}++ } }
+{
+ my $o = bless \(my $dummy = "a"), o::;
+ $_ = join $o, 1..10;
+ is $_, "1a2a3a4a5a6a7a8a9a10", 'join, $overloaded, LIST';
+ is $$o, "b", 'overloading was called once on overloaded separator';
+}
BEGIN { chdir 't' if -d 't'; require './test.pl'; }
-plan(tests => 8);
+plan(tests => 10);
{
no warnings 'deprecated';
."2.\n",
'no buffer corruption with multiline *{...expr...}'
;
+
+$_ = "rhubarb";
+is ${no strict; \$_}, "rhubarb", '${no strict; ...}';
+is join("", map{no strict; "rhu$_" } "barb"), 'rhubarb',
+ 'map{no strict;...}';
#!./perl
+# Test that $lexical = <some op> optimises the assignment away correctly
+# and causes no ill side-effects.
+
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
$xxx = 'c' . ($xxx || 'e');
is( $xxx, 'cb', 'variables can be read before being overwritten');
-{ # Check calling STORE
- note('Tied variables, calling STORE');
- my $sc = 0;
- sub B::TIESCALAR {bless [11], 'B'}
- sub B::FETCH { -(shift->[0]) }
- sub B::STORE { $sc++; my $o = shift; $o->[0] = 17 + shift }
-
- my $m;
- tie $m, 'B';
- $m = 100;
-
- is( $sc, 1, 'STORE called when assigning scalar to tied variable' );
-
- my $t = 11;
- $m = $t + 89;
-
- is( $sc, 2, 'and again' );
- is( $m, -117, 'checking the tied variable result' );
-
- $m += $t;
-
- is( $sc, 3, 'called on self-increment' );
- is( $m, 89, 'checking the tied variable result' );
-
-}
-
# Chains of assignments
my ($l1, $l2, $l3, $l4);
$op = "$op==$op" unless $op =~ /==/;
($op, $expectop) = $op =~ /(.*)==(.*)/;
- $skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i)
- ? "skip" : "# '$_'\nnot";
+ $skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i);
$integer = ($comment =~ /^i_/) ? "use integer" : '' ;
- if ($skip eq 'skip') {
+ if ($skip) {
SKIP: {
skip $comment, 1;
- pass();
}
next;
}
$integer;
\$a = $op;
\$b = $expectop;
- if (\$a ne \$b) {
- SKIP: {
- skip "\$comment: got '\$a', expected '\$b'", 1;
- pass("")
- }
- }
- pass();
+ is (\$a, \$b, \$comment);
EOE
if ($@) {
$warning = $@;
chomp $warning;
- if ($@ =~ /is unimplemented/) {
- SKIP: {
- skip $warning, 1;
- pass($comment);
- }
- } else {
+ if ($@ !~ /(?:is un|not )implemented/) {
fail($_ . ' ' . $warning);
}
}
}
+{ # Check calling STORE
+ note('Tied variables, calling STORE');
+ my $sc = 0;
+ sub B::TIESCALAR {bless [11], 'B'}
+ sub B::FETCH { -(shift->[0]) }
+ sub B::STORE { $sc++; my $o = shift; $o->[0] = 17 + shift }
+
+ my $m;
+ tie $m, 'B';
+ $m = 100;
+
+ is( $sc, 1, 'STORE called when assigning scalar to tied variable' );
+
+ my $t = 11;
+ $m = $t + 89;
+
+ is( $sc, 2, 'and again' );
+ is( $m, -117, 'checking the tied variable result' );
+
+ $m += $t;
+
+ is( $sc, 3, 'called on self-increment' );
+ is( $m, 89, 'checking the tied variable result' );
+
+ for (@INPUT) {
+ ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/;
+ $comment = $op unless defined $comment;
+ next if ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i);
+ $op =~ s/==.*//;
+
+ $sc = 0;
+ local $SIG{__WARN__} = \&wrn;
+ eval "\$m = $op";
+ like $sc, $@ ? qr/^[01]\z/ : qr/^1\z/, "STORE count for $comment";
+ }
+}
+
for (@simple_input) {
($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/;
$comment = $op unless defined $comment;
if ($@) {
$warning = $@;
chomp $warning;
- if ($@ =~ /is unimplemented/) {
+ if ($@ =~ /(?:is un|not )implemented/) {
SKIP: {
skip $warning, 1;
pass($comment);
}
}
+# XXX This test does not really belong here, as it has nothing to do with
+# OPpTARGET_MY optimisation. But where should it go?
eval {
sub PVBM () { 'foo' }
index 'foo', PVBM;
$n | $n # bit_or
-$n # negate
-$n # i_negate
+-$a=="-fake" # i_negate with string
~$n # complement
atan2 $n,$n # atan2
sin $n # sin
sprintf "%i%i", $n, $n # sprintf
ord $n # ord
chr $n # chr
+chr ${\256} # chr $wide
crypt $n, $n # crypt
ucfirst ($cstr . "a") # ucfirst padtmp
ucfirst $cstr # ucfirst
'???' # kill
getppid # getppid
getpgrp # getpgrp
-'???' # setpgrp
+setpgrp # setpgrp
getpriority $$, $$ # getpriority
'???' # setpriority
time # time
*bar::is = *is;
*bar::like = *like;
}
-plan 143;
+plan 144;
# -------------------- Errors with feature disabled -------------------- #
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 }
+ sub DB::sub{
+ print qq|4\n| unless $DB::sub =~ DESTROY;
+ goto $DB::sub
+ }
state sub foo {print qq|2\n|}
foo();
'
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 }
+ sub DB::sub{
+ print qq|4\n| unless $DB::sub =~ DESTROY;
+ goto $DB::sub
+ }
my sub foo {print qq|2\n|}
foo();
'
print handel,"ok ",curr_test()," - no 'No comma allowed' after my sub\n";
curr_test(curr_test()+1);
}
+{
+ my $x = 43;
+ my sub y :prototype() {$x};
+ is y, 43, 'my sub that looks like constant closure';
+}
# -------------------- Interactions (and misc tests) -------------------- #
}
require "./test.pl";
-plan( tests => 66 );
+plan( tests => 67 );
@foo = (1, 2, 3, 4);
cmp_ok($foo[0], '==', 1, 'first elem');
($a,$b) = ($b = $foo."", $a = $bar . "");
is("$a,$b", "foo,bar", 'common vars check accounts for OPpTARGET_MY');
}
+
+sub TIESCALAR {bless{}}
+sub FETCH {$_[0]{fetched}++}
+sub empty {}
+tie $t, "";
+() = (empty(), ($t)x10); # empty() since sub calls usually result in copies
+is(tied($t)->{fetched}, undef, 'assignment to empty list makes no copies');
is ($refref->$*->$*, 'Good'); # is ($$$refref, 'Good');
-# Test nested anonymous lists.
+# Test nested anonymous arrays.
$ref = [[],2,[3,4,5,]];
is (scalar $ref->@*, 3); # is (scalar @$ref, 3);
$x = "Good";
is ($$$refref, 'Good');
-# Test nested anonymous lists.
+# Test nested anonymous arrays.
$ref = [[],2,[3,4,5,]];
is (scalar @$ref, 3);
}
require './test.pl';
-plan(tests => 43);
+plan(tests => 47);
# compile time
is(join('', @x x -12), '', '@x x -12');
is(join('', (@x) x -14), '', '(@x) x -14');
+($a, (undef)x5, $b) = 1..10;
+is ("$a $b", "1 7", '(undef)xCONST on lhs of list assignment');
+(($a)x3,$b) = 1..10;
+is ("$a, $b", "3, 4", '($x)xCONST on lhs of list assignment');
+($a, (undef)x${\6}, $b) = "a".."z";
+is ("$a$b", "ah", '(undef)x$foo on lhs of list assignment');
+
# This test is actually testing for Digital C compiler optimizer bug,
# present in Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS),
is($x, "22", 'list repeat in scalar context');
is($y, undef, ' no extra values on stack');
-# Make sure the stack doesn't get truncated too much - the left
-# operand of the eq binop needs to remain!
+# Make sure the stack doesn't get truncated too much - the first
+# argument to is() needs to remain!
is(77, scalar ((1,7)x2), 'stack truncation');
+# ( )x in void context should not read preceding stack items
+package Tiecount {
+ sub TIESCALAR { bless[]} sub FETCH { our $Tiecount++; study; 3 }
+}
+sub nil {}
+tie my $t, "Tiecount";
+{ push my @temp, $t, scalar((nil) x 3, 1) }
+is($Tiecount::Tiecount, 1,
+ '(...)x... in void context in list (via scalar comma)');
+
# perlbug 20011113.110 works in 5.6.1, broken in 5.7.2
{
is( join('', @$x), 'foofoo', 'list repeat in anon array ref broken [ID 20011113.110]' );
}
-# [ID 20010809.028] x operator not copying elements in 'for' list?
-{
- local $TODO = "x operator not copying elements in 'for' list? [ID 20010809.028]";
- my $x = 'abcd';
- my $y = '';
- for (($x =~ /./g) x 2) {
- $y .= chop;
- }
- is($y, 'abcdabcd');
-}
-
# [perl #35885]
is( (join ',', (qw(a b c) x 3)), 'a,b,c,a,b,c,a,b,c', 'x on qw produces list' );
'[perl #78194] \$_[0] == \$_[1] when @_ aliases elems repeated by x')
}
->(("${\''}")x2);
+
+$#that_array = 7;
+for(($#that_array)x2) {
+ $_ *= 2;
+}
+is($#that_array, 28, 'list repetition propagates lvalue cx to its lhs');
#!perl -w
-use strict;
# Check that require doesn't leave the handle it uses open, if it happens that
# the handle it opens gets file descriptor 0. RT #37033.
require './test.pl';
@INC = 'lib';
+use strict;
+
sub test_require {
my ($state, $want) = @_;
delete $INC{'test_use_14937.pm'};
#!perl
-use strict;
-use warnings;
BEGIN {
chdir 't' if -d 't';
require './test.pl';
}
+use strict;
+use warnings;
+
plan(tests => 17);
my $nonfile = tempfile();
@a = sort { last foo; } @a;
}
EXPECT
-Label not found for "last foo" at - line 2.
+Label not found for "last foo" at - line 4.
########
package TEST;
is prototype(\&t002), undef;
is eval("t002()"), 123;
is eval("t002(456)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t002(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t003 ( ) { $a || "z" }
is prototype(\&t003), undef;
is eval("t003()"), 123;
is eval("t003(456)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t003(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t006 ($a) { $a || "z" }
is prototype(\&t006), undef;
is eval("t006()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t006(0)"), "z";
is eval("t006(456)"), 456;
is eval("t006(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t006(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t007 ($a, $b) { $a.$b }
is prototype(\&t007), undef;
is eval("t007()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t007(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t007(456, 789)"), "456789";
is eval("t007(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t007(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t008 ($a, $b, $c) { $a.$b.$c }
is prototype(\&t008), undef;
is eval("t008()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t008(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t008(456, 789)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t008(456, 789, 987)"), "456789987";
is eval("t008(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t009 ($abc, $def) { $abc.$def }
is prototype(\&t009), undef;
is eval("t009()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t009(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t009(456, 789)"), "456789";
is eval("t009(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t009(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t010 ($a, $) { $a || "z" }
is prototype(\&t010), undef;
is eval("t010()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t010(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t010(0, 789)"), "z";
is eval("t010(456, 789)"), 456;
is eval("t010(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t010(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t011 ($, $a) { $a || "z" }
is prototype(\&t011), undef;
is eval("t011()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t011(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t011(456, 0)"), "z";
is eval("t011(456, 789)"), 789;
is eval("t011(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t011(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t012 ($, $) { $a || "z" }
is prototype(\&t012), undef;
is eval("t012()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t012(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t012(0, 789)"), 123;
is eval("t012(456, 789)"), 123;
is eval("t012(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t012(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t013 ($) { $a || "z" }
is prototype(\&t013), undef;
is eval("t013()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t013(0)"), 123;
is eval("t013(456)"), 123;
is eval("t013(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t013(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t013(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t014 ($a = 222) { $a // "z" }
is eval("t014(undef)"), "z";
is eval("t014(456)"), 456;
is eval("t014(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t014(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t015 ($a = undef) { $a // "z" }
is eval("t015(undef)"), "z";
is eval("t015(456)"), 456;
is eval("t015(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t015(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t016 ($a = do { $z++; 222 }) { $a // "z" }
is eval("t016(undef)"), "z";
is eval("t016(456)"), 456;
is eval("t016(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t016(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $z, 1;
is eval("t016()"), 222;
is $z, 2;
is eval("t017(undef)"), "z";
is eval("t017(456)"), 456;
is eval("t017(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t017(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t019 ($p = 222, $a = 333) { "$p/$a" }
is eval("t019(456)"), "456/333";
is eval("t019(456, 789)"), "456/789";
is eval("t019(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t020 :prototype($) { $_[0]."z" }
is eval("t021(456)"), "456/333";
is eval("t021(456, 789)"), "456/789";
is eval("t021(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t022 ($p = do { $z += 10; 222 }, $a = do { $z++; 333 }) { "$p/$a" }
is $z, 13;
is eval("t022(456, 789)"), "456/789";
is eval("t022(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $z, 13;
is $a, 123;
is eval("t023()"), "azy";
is eval("t023(sub { \"x\".\$_[0].\"x\" })"), "xaxy";
is eval("t023(sub { \"x\".\$_[0].\"x\" }, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t036 ($a = $a."x") { $a."y" }
is eval("t036(0)"), "0y";
is eval("t036(456)"), "456y";
is eval("t036(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t120 ($a = $_) { $a // "z" }
is eval("t120(456)"), 456;
$_ = "___";
is eval("t120(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t121 ($a = caller) { $a // "z" }
is eval("t121(0)"), 0;
is eval("t121(456)"), 456;
is eval("t121(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("package T121::Z; ::t121()"), "T121::Z";
is eval("package T121::Z; ::t121(undef)"), "z";
is eval("package T121::Z; ::t121(0)"), 0;
is eval("package T121::Z; ::t121(456)"), 456;
is eval("package T121::Z; ::t121(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t129 ($a = return 222) { $a."x" }
is eval("t129(0)"), "0x";
is eval("t129(456)"), "456x";
is eval("t129(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
use feature "current_sub";
is eval("t122(5)"), "543210";
is eval("t122(5, 789)"), "5789";
is eval("t122(5, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t123 ($list = wantarray) { $list ? "list" : "scalar" }
is eval("scalar(t123(1))"), "list";
is eval("(t123(1))[0]"), "list";
is eval("t123(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t124 ($b = (local $a = $a + 1)) { "$a/$b" }
is eval("t124(456)"), "123/456";
is $a, 123;
is eval("t124(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t125 ($c = (our $t125_counter)++) { $c }
is eval("t125()"), 3;
is eval("t125()"), 4;
is eval("t125(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
use feature "state";
is eval("t126()"), 222;
is $z, 223;
is eval("t126(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $z, 223;
is $a, 123;
is eval("t127()"), 225;
is eval("t127()"), 226;
is eval("t127(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $z, 223;
is $a, 123;
is eval("t037(456)"), "456/456x";
is eval("t037(456, 789)"), "456/789";
is eval("t037(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t128 ($a = 222, $b = ($a = 333)) { "$a/$b" }
is eval("t128(456)"), "333/333";
is eval("t128(456, 789)"), "456/789";
is eval("t128(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t130 { join(",", @_).";".scalar(@_) }
is eval("t131(456)"), "456;1";
is eval("t131(456, 789)"), "456/789";
is eval("t131(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
eval "#line 8 foo\nsub t024 (\$a =) { }";
is eval("t025(0)"), 123;
is eval("t025(456)"), 123;
is eval("t025(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t025(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t025(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t026 ($ = 222) { $a // "z" }
is eval("t026(0)"), 123;
is eval("t026(456)"), 123;
is eval("t026(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t026(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t026(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t032 ($ = do { $z++; 222 }) { $a // "z" }
is eval("t032(0)"), 123;
is eval("t032(456)"), 123;
is eval("t032(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t032(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t032(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $z, 1;
is $a, 123;
is eval("t027(0)"), 123;
is eval("t027(456)"), 123;
is eval("t027(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t027(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t027(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t119 ($ =, $a = 333) { $a // "z" }
is eval("t119(456)"), 333;
is eval("t119(456, 789)"), 789;
is eval("t119(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t119(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t028 ($a, $b = 333) { "$a/$b" }
is prototype(\&t028), undef;
is eval("t028()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t028(0)"), "0/333";
is eval("t028(456)"), "456/333";
is eval("t028(456, 789)"), "456/789";
is eval("t028(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t045 ($a, $ = 333) { "$a/" }
is prototype(\&t045), undef;
is eval("t045()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t045(0)"), "0/";
is eval("t045(456)"), "456/";
is eval("t045(456, 789)"), "456/";
is eval("t045(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t046 ($, $b = 333) { "$a/$b" }
is prototype(\&t046), undef;
is eval("t046()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t046(0)"), "123/333";
is eval("t046(456)"), "123/333";
is eval("t046(456, 789)"), "123/789";
is eval("t046(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t047 ($, $ = 333) { "$a/" }
is prototype(\&t047), undef;
is eval("t047()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t047(0)"), "123/";
is eval("t047(456)"), "123/";
is eval("t047(456, 789)"), "123/";
is eval("t047(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t029 ($a, $b, $c = 222, $d = 333) { "$a/$b/$c/$d" }
is prototype(\&t029), undef;
is eval("t029()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t029(0)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t029(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t029(456, 789)"), "456/789/222/333";
is eval("t029(456, 789, 987)"), "456/789/987/333";
is eval("t029(456, 789, 987, 654)"), "456/789/987/654";
is eval("t029(456, 789, 987, 654, 321)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t029(456, 789, 987, 654, 321, 111)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t038 ($a, $b = $a."x") { "$a/$b" }
is prototype(\&t038), undef;
is eval("t038()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t038(0)"), "0/0x";
is eval("t038(456)"), "456/456x";
is eval("t038(456, 789)"), "456/789";
is eval("t038(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
eval "#line 8 foo\nsub t030 (\$a = 222, \$b) { }";
is prototype(\&t039), undef;
is eval("t039()"), "";
is eval("t039(0)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t039(456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t039(456, 789)"), "456=789";
is eval("t039(456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t039(456, 789, 987, 654)"), "456=789/987=654";
is eval("t039(456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t039(456, 789, 987, 654, 321, 111)"), "321=111/456=789/987=654";
is $a, 123;
is prototype(\&t040), undef;
is eval("t040()"), 123;
is eval("t040(0)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t040(456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t040(456, 789)"), 123;
is eval("t040(456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t040(456, 789, 987, 654)"), 123;
is eval("t040(456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t040(456, 789, 987, 654, 321, 111)"), 123;
is $a, 123;
sub t041 ($a, @b) { $a.";".join("/", @b) }
is prototype(\&t041), undef;
is eval("t041()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t041(0)"), "0;";
is eval("t041(456)"), "456;";
is eval("t041(456, 789)"), "456;789";
sub t042 ($a, @) { $a.";" }
is prototype(\&t042), undef;
is eval("t042()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t042(0)"), "0;";
is eval("t042(456)"), "456;";
is eval("t042(456, 789)"), "456;";
sub t043 ($, @b) { $a.";".join("/", @b) }
is prototype(\&t043), undef;
is eval("t043()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t043(0)"), "123;";
is eval("t043(456)"), "123;";
is eval("t043(456, 789)"), "123;789";
sub t044 ($, @) { $a.";" }
is prototype(\&t044), undef;
is eval("t044()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t044(0)"), "123;";
is eval("t044(456)"), "123;";
is eval("t044(456, 789)"), "123;";
sub t049 ($a, %b) { $a.";".join("/", map { $_."=".$b{$_} } sort keys %b) }
is prototype(\&t049), undef;
is eval("t049()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t049(222)"), "222;";
is eval("t049(222, 456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t049(222, 456, 789)"), "222;456=789";
is eval("t049(222, 456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t049(222, 456, 789, 987, 654)"), "222;456=789/987=654";
is eval("t049(222, 456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t049(222, 456, 789, 987, 654, 321, 111)"),
"222;321=111/456=789/987=654";
is $a, 123;
sub t051 ($a, $b, $c, @d) { "$a;$b;$c;".join("/", @d).";".scalar(@d) }
is prototype(\&t051), undef;
is eval("t051()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t051(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t051(456, 789)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t051(456, 789, 987)"), "456;789;987;;0";
is eval("t051(456, 789, 987, 654)"), "456;789;987;654;1";
is eval("t051(456, 789, 987, 654, 321)"), "456;789;987;654/321;2";
sub t052 ($a, $b, %c) { "$a;$b;".join("/", map { $_."=".$c{$_} } sort keys %c) }
is prototype(\&t052), undef;
is eval("t052()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t052(222)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t052(222, 333)"), "222;333;";
is eval("t052(222, 333, 456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t052(222, 333, 456, 789)"), "222;333;456=789";
is eval("t052(222, 333, 456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t052(222, 333, 456, 789, 987, 654)"), "222;333;456=789/987=654";
is eval("t052(222, 333, 456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t052(222, 333, 456, 789, 987, 654, 321, 111)"),
"222;333;321=111/456=789/987=654";
is $a, 123;
}
is prototype(\&t053), undef;
is eval("t053()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t053(222)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t053(222, 333)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t053(222, 333, 444)"), "222;333;444;";
is eval("t053(222, 333, 444, 456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t053(222, 333, 444, 456, 789)"), "222;333;444;456=789";
is eval("t053(222, 333, 444, 456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t053(222, 333, 444, 456, 789, 987, 654)"),
"222;333;444;456=789/987=654";
is eval("t053(222, 333, 444, 456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t053(222, 333, 444, 456, 789, 987, 654, 321, 111)"),
"222;333;444;321=111/456=789/987=654";
is $a, 123;
is eval("t050()"), "211;";
is eval("t050(222)"), "222;";
is eval("t050(222, 456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t050(222, 456, 789)"), "222;456=789";
is eval("t050(222, 456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t050(222, 456, 789, 987, 654)"), "222;456=789/987=654";
is eval("t050(222, 456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t050(222, 456, 789, 987, 654, 321, 111)"),
"222;321=111/456=789/987=654";
is $a, 123;
is eval("t056(222)"), "222;311;";
is eval("t056(222, 333)"), "222;333;";
is eval("t056(222, 333, 456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t056(222, 333, 456, 789)"), "222;333;456=789";
is eval("t056(222, 333, 456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t056(222, 333, 456, 789, 987, 654)"), "222;333;456=789/987=654";
is eval("t056(222, 333, 456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t056(222, 333, 456, 789, 987, 654, 321, 111)"),
"222;333;321=111/456=789/987=654";
is $a, 123;
is eval("t057(222, 333)"), "222;333;411;";
is eval("t057(222, 333, 444)"), "222;333;444;";
is eval("t057(222, 333, 444, 456)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t057(222, 333, 444, 456, 789)"), "222;333;444;456=789";
is eval("t057(222, 333, 444, 456, 789, 987)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t057(222, 333, 444, 456, 789, 987, 654)"),
"222;333;444;456=789/987=654";
is eval("t057(222, 333, 444, 456, 789, 987, 654, 321)"), undef;
-like $@, qr#\AOdd name/value argument for subroutine at#;
+like $@, qr#\AOdd name/value argument for subroutine at \(eval \d+\) line 1\.\n\z#;
is eval("t057(222, 333, 444, 456, 789, 987, 654, 321, 111)"),
"222;333;444;321=111/456=789/987=654";
is $a, 123;
sub t058 ($a, $b = 333, @c) { "$a;$b;".join("/", @c).";".scalar(@c) }
is prototype(\&t058), undef;
is eval("t058()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t058(456)"), "456;333;;0";
is eval("t058(456, 789)"), "456;789;;0";
is eval("t058(456, 789, 987)"), "456;789;987;1";
sub t080 ($a,,, $b) { $a.$b }
is prototype(\&t080), undef;
is eval("t080()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t080(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t080(456, 789)"), "456789";
is eval("t080(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t080(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t081 ($a, $b,,) { $a.$b }
is prototype(\&t081), undef;
is eval("t081()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t081(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t081(456, 789)"), "456789";
is eval("t081(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t081(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
eval "#line 8 foo\nsub t082 (, \$a) { }";
sub t084($a,$b){ $a.$b }
is prototype(\&t084), undef;
is eval("t084()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t084(456)"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t084(456, 789)"), "456789";
is eval("t084(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t084(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t085
{ $a.$b }
is prototype(\&t085), undef;
is eval("t085()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t085(456)"), "456333";
is eval("t085(456, 789)"), "456789";
is eval("t085(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t085(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t086
{ $a.$b }
is prototype(\&t086), undef;
is eval("t086()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t086(456)"), "456333";
is eval("t086(456, 789)"), "456789";
is eval("t086(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t086(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t087
{ $a.$b }
is prototype(\&t087), undef;
is eval("t087()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t087(456)"), "456333";
is eval("t087(456, 789)"), "456789";
is eval("t087(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t087(456, 789, 987, 654)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
eval "#line 8 foo\nsub t088 (\$ #foo\na) { }";
is prototype(\&t100), undef;
$_ = "___";
is eval("t100()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
$_ = "___";
is eval("t100(0)"), "___/0";
$_ = "___";
is eval("t100(456)"), "___/456";
$_ = "___";
is eval("t100(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
$_ = "___";
is eval("t100(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
eval "#line 8 foo\nsub t101 (\@_) { }";
my $t103 = sub ($a) { $a || "z" };
is prototype($t103), undef;
is eval("\$t103->()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("\$t103->(0)"), "z";
is eval("\$t103->(456)"), 456;
is eval("\$t103->(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("\$t103->(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
my $t118 = sub :prototype($) ($a) { $a || "z" };
is prototype($t118), "\$";
is eval("\$t118->()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("\$t118->(0)"), "z";
is eval("\$t118->(456)"), 456;
is eval("\$t118->(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("\$t118->(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t033 ($a = sub ($a) { $a."z" }) { $a->("a")."y" }
is eval("t033()"), "azy";
is eval("t033(sub { \"x\".\$_[0].\"x\" })"), "xaxy";
is eval("t033(sub { \"x\".\$_[0].\"x\" }, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t133 ($a = sub ($a = 222) { $a."z" }) { $a->()."/".$a->("a") }
is eval("t133()"), "222z/az";
is eval("t133(sub { \"x\".(\$_[0] // \"u\").\"x\" })"), "xux/xax";
is eval("t133(sub { \"x\".(\$_[0] // \"u\").\"x\" }, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t134 ($a = sub ($a, $t = sub { $_[0]."p" }) { $t->($a)."z" }) {
"xax/xbqx";
is eval("t134(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" }, 789)"),
undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t135 ($a = sub ($a, $t = sub ($p) { $p."p" }) { $t->($a)."z" }) {
"xax/xbqx";
is eval("t135(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" }, 789)"),
undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t132 (
"xax/xbqx";
is eval("t132(sub { \"x\".(\$_[1] // sub{\$_[0]})->(\$_[0]).\"x\" }, 789)"),
undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t104 :method ($a) { $a || "z" }
is prototype(\&t104), undef;
is eval("t104()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t104(0)"), "z";
is eval("t104(456)"), 456;
is eval("t104(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t104(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
sub t105 :prototype($) ($a) { $a || "z" }
is eval("t105(0)"), "z";
is eval("t105(456)"), 456;
is eval("t105(456, 789)"), undef;
-like $@, qr/\AToo many arguments for main::t105 at/;
+like $@, qr/\AToo many arguments for main::t105 at \(eval \d+\) line 1, near/;
is eval("t105(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for main::t105 at/;
+like $@, qr/\AToo many arguments for main::t105 at \(eval \d+\) line 1, near/;
is $a, 123;
sub t106 :prototype(@) ($a) { $a || "z" }
is prototype(\&t106), "\@";
is eval("t106()"), undef;
-like $@, qr/\AToo few arguments for subroutine at/;
+like $@, qr/\AToo few arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t106(0)"), "z";
is eval("t106(456)"), 456;
is eval("t106(456, 789)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is eval("t106(456, 789, 987)"), undef;
-like $@, qr/\AToo many arguments for subroutine at/;
+like $@, qr/\AToo many arguments for subroutine at \(eval \d+\) line 1\.\n\z/;
is $a, 123;
eval "#line 8 foo\nsub t107 (\$a) :method { }";
}
use strict;
use warnings;
-no warnings 'deprecated', 'experimental::autoderef';
+no warnings 'experimental::autoderef', 'experimental::refaliasing';
use vars qw($data $array $values $hash $errpat);
plan 'no_plan';
like($@, $errpat, "Overload: ambiguous dereference");
is($warn, '', "no warning issued"); $warn = '';
}
+
+use feature 'refaliasing';
+my $a = 7;
+our %h;
+\$h{f} = \$a;
+($a, $b) = each \%h;
+is "$a $b", "f 7", 'each \%hash in list assignment';
+$a = 7;
+($a, $b) = (3, values \%h);
+is "$a $b", "3 7", 'values \%hash in list assignment';
+*a = sub { \@_ }->($a);
+$a = 7;
+($a, $b) = each \our @a;
+is "$a $b", "0 7", 'each \@array in list assignment';
+$a = 7;
+($a, $b) = (3, values \@a);
+is "$a $b", "3 7", 'values \@array in list assignment';
set_up_inc('../lib');
}
-plan tests => 122;
+plan tests => 125;
$FS = ':';
() = @a = split //, "abc";
is "@a", "a b c", '() = split-to-array';
+
+(@a = split //, "abc") = 1..10;
+is "@a", '1 2 3', 'assignment to split-to-array (pmtarget/package array)';
+{
+ my @a;
+ (@a = split //, "abc") = 1..10;
+ is "@a", '1 2 3', 'assignment to split-to-array (targ/lexical)';
+}
+(@{\@a} = split //, "abc") = 1..10;
+is "@a", '1 2 3', 'assignment to split-to-array (stacked)';
eval { my $q = pack "q", 0 };
my $Q = $@ eq '';
+my $doubledouble;
+
# %a and %A depend on the floating point config
# This totally doesn't test non-IEEE-754 float formats.
my @hexfloat;
(pack("F", 0.1) =~ /^\x9A\x99{5}\x59\xBC/ || # LE
pack("F", 0.1) =~ /\xBC\x59\x99{5}\x9A$/) # BE
) {
+ $doubledouble = 1;
@hexfloat = (
[ '%a', '0', '0x0p+0' ],
[ '%a', '1', '0x1p+0' ],
() = sprintf "%.1s", $o;
is $o::count, '1', 'sprinf %.1s overload count';
+my $ppc64_linux = $Config{archname} =~ /^ppc64-linux/;
+
for my $t (@hexfloat) {
my ($format, $arg, $expected) = @$t;
$arg = eval $arg;
my $result = sprintf($format, $arg);
my $ok = $result eq $expected;
+ if ($doubledouble && $ppc64_linux && $arg =~ /^2.71828/) {
+ # ppc64-linux has buggy exp(1).
+ local $::TODO = "$Config{archname} exp(1)";
+ ok($ok, "'$format' '$arg' -> '$result' cf '$expected'");
+ next;
+ }
unless ($ok) {
# It seems that there can be difference in the last bits:
# [perl #122578]
use strict;
-plan tests => 136;
+plan tests => 137;
# Before loading feature.pm, test it with CORE::
ok eval 'CORE::state $x = 1;', 'CORE::state outside of feature.pm scope';
thing2(6);
}
+# [perl #123029] regression in "state" under PERL_NO_COW
+sub rt_123029 {
+ state $s;
+ $s = 'foo'x500;
+ my $c = $s;
+ return defined $s;
+}
+ok(rt_123029(), "state variables don't surprisingly disappear when accessed");
__DATA__
state ($a) = 1;
set_up_inc('../lib');
}
-plan( tests => 38 );
+plan( tests => 35 );
sub empty_sub {}
Munchy(Crunchy);
} || $@, 2, 'freeing ops does not make sub(){42} immutable';
-# [perl #79908]
-{
- my $x = 5;
- *_79908 = sub (){$x};
- $x = 7;
- TODO: {
- local $TODO = "Should be fixed with a deprecation cycle, see 'How about having a recommended way to add constant subs dynamically?' on p5p";
- is eval "_79908", 7, 'sub(){$x} does not break closures';
- }
- isnt eval '\_79908', \$x, 'sub(){$x} returns a copy';
-
- # Test another thing that was broken by $x inlinement
- my $y;
- no warnings 'once';
- local *time = sub():method{$y};
- my $w;
- local $SIG{__WARN__} = sub { $w .= shift };
- eval "()=time";
- TODO: {
- local $TODO = "Should be fixed with a deprecation cycle, see 'How about having a recommended way to add constant subs dynamically?' on p5p";
- is $w, undef,
- '*keyword = sub():method{$y} does not cause ambiguity warnings';
- }
-}
-
# &xsub when @_ has nonexistent elements
{
no warnings "uninitialized";
use Config;
-plan tests => 127;
+plan tests => 128;
# run some code N times. If the number of SVs at the end of loop N is
# greater than (N-1)*delta at the end of loop 1, we've got a leak
eleak(2,0,'/[[:ascii:]]/');
eleak(2,0,'/[[.zog.]]/');
eleak(2,0,'/[.zog.]/');
+eleak(2,0,'/|\W/', '/|\W/ [perl #123198]');
eleak(2,0,'no warnings; /(?[])/');
eleak(2,0,'no warnings; /(?[[a]+[b]])/');
eleak(2,0,'no warnings; /(?[[a]-[b]])/');
untie %h;
EXPECT
########
-# SKIP !defined &DynaLoader::boot_DynaLoader && !eval 'require base'
+# 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
print
EXPECT
crumpets
+########
+
+# tied() in list assignment
+
+sub TIESCALAR : lvalue {
+ ${+pop} = bless [], shift;
+}
+tie $t, "", \$a;
+$a = 7;
+($a, $b) = (3, tied $t);
+print "a is $a\n";
+print "b is $b\n";
+EXPECT
+a is 3
+b is 7
chdir 't' if -d 't';
require './test.pl';
set_up_inc('../lib');
- plan (tests => 340);
+ plan (tests => 344);
}
use strict;
check_count "$op $args\\\$tied_glob$postargs";
}
+$dummy = crypt $var,0; check_count 'crypt $tied, ...';
+$dummy = crypt 0,$var; check_count 'crypt ..., $tied';
+$var = substr(chr 256,0,0);
+$dummy = crypt $var,0; check_count 'crypt $tied_utf8, ...';
+$var = substr(chr 256,0,0);
+$dummy = crypt 0,$var; check_count 'crypt ..., $tied_utf8';
+
{
no warnings;
$var = *foo;
use strict;
-plan(tests => 15);
+plan(tests => 16);
SKIP: {
-skip_without_dynamic_extension("Devel::Peek");
+skip_without_dynamic_extension("Devel::Peek", 2);
-my $pid = open CHILD, '-|';
-die "kablam: $!\n" unless defined $pid;
-unless ($pid) {
- open STDERR, ">&STDOUT";
- $a = "hello \x{1234}";
+my $out = runperl(stderr => 1,
+ progs => [ split /\n/, <<'EOS' ]);
+ require Devel::Peek;
+ $a = qq(hello \x{1234});
for (1..2) {
bar(substr($a, $_, 1));
}
sub bar {
- $_[0] = "\x{4321}";
+ $_[0] = qq(\x{4321});
Devel::Peek::Dump($_[0]);
}
- exit;
-}
+EOS
-{ local $/; $_ = <CHILD> }
+like($out, qr/\ASV =/, "check we got dump output"); # [perl #121337]
my $utf8magic = qr{ ^ \s+ MAGIC \s = .* \n
\s+ MG_VIRTUAL \s = .* \n
\s+ MG_TYPE \s = \s PERL_MAGIC_utf8 .* \n
\s+ MG_LEN \s = .* \n }xm;
-unlike($_, qr{ $utf8magic $utf8magic }x);
+unlike($out, qr{ $utf8magic $utf8magic }x,
+ "no duplicate utf8 magic");
} # SKIP
--- /dev/null
+#!perl
+
+# This file specifies a hash-of-hashes that define snippets of code that
+# can be run by various measurement and profiling tools.
+#
+# The basic idea is that any time you add an optimisation that is intended
+# to make a particular construct faster, then you should add that construct
+# to this file.
+#
+# Under the normal test suite, the test file benchmarks.t does a basic
+# compile and run of each of these snippets; not to test performance,
+# but just to ensure that the code doesn't have errors.
+#
+# Over time, it is intended that various measurement and profiling tools
+# will be written that can run selected (or all) snippets in various
+# environments. These will not be run as part of a normal test suite run.
+#
+# This file is designed to be read in by 'do' (and in such a way that
+# multiple versions of this file from different releases can be read in
+# by a single process).
+#
+# Each key of the top-level hash is a token that describes a particular
+# test. Code will be compiled in the package named after the token, so it
+# should match /^\w+$/a. It is intended that this can be used on the
+# command line of tools to select particular tests, .
+#
+# Each value is also a hash, with three fields:
+#
+# desc is a description of the test
+# setup is a string containing setup code
+# code is a string containing the code to run in a loop
+#
+# So typically a benchmark tool might do something like
+#
+# eval "package $token; $setup; for (1..1000000) { $code }"
+
+
+{
+ arg_assignment => {
+ desc => 'assignment to local vars from @_',
+ setup => 'sub arg_assignment { my ($a, $b, $c) = @_ }',
+ code => 'arg_assignment(1,2,3)',
+ },
+};
+
--- /dev/null
+#!./perl
+#
+# Execute the various code snippets in t/perf/benchmarks
+# to ensure that they are all syntactically correct
+
+BEGIN {
+ chdir 't';
+ require './test.pl';
+ @INC = ('.', '../lib');
+}
+
+use warnings;
+use strict;
+
+
+my $file = 'perf/benchmarks';
+my $benchmarks = do $file;
+die $@ if $@;
+die "$! while trying to read '$file'" if $!;
+die "'$file' did not return a hash ref\n" unless ref $benchmarks eq 'HASH';
+
+plan keys(%$benchmarks) * 3;
+
+
+# check the hash of hashes is minimally consistent in format
+
+for my $token (sort keys %$benchmarks) {
+ like($token, qr/^[a-zA-Z]\w*$/a, "legal token: $token");
+ my $keys = join('-', sort keys %{$benchmarks->{$token}});
+ is($keys, 'code-desc-setup', "legal keys: $token");
+}
+
+# check that each bit of code compiles and runs
+
+for my $token (sort keys %$benchmarks) {
+ my $b = $benchmarks->{$token};
+ my $code = "package $token; $b->{setup}; for (1..1) { $b->{code} } 1;";
+ ok(eval $code, "running $token")
+ or do {
+ diag("code:");
+ diag($code);
+ diag("gave:");
+ diag($@);
+ }
+}
+
+
--- /dev/null
+#!./perl
+#
+# opcount.t
+#
+# Test whether various constructs have the right numbers of particular op
+# types. This is chiefly to test that various optimisations are not
+# inadvertently removed.
+#
+# For example the array access in sub { $a[0] } should get optimised from
+# aelem into aelemfast. So we want to test that there are 1 aelemfast, 0
+# aelem and 1 ex-aelem ops in the optree for that sub.
+
+BEGIN {
+ chdir 't';
+ require './test.pl';
+ skip_all_if_miniperl("No B under miniperl");
+ @INC = '../lib';
+}
+
+plan 3;
+
+use B ();
+
+
+{
+ my %counts;
+
+ # for a given op, increment $count{opname}. Treat null ops
+ # as "ex-foo" where possible
+
+ sub B::OP::test_opcount_callback {
+ my ($op) = @_;
+ my $name = $op->name;
+ if ($name eq 'null') {
+ my $targ = $op->targ;
+ if ($targ) {
+ $name = "ex-" . substr(B::ppname($targ), 3);
+ }
+ }
+ $counts{$name}++;
+ }
+
+ # Given a code ref and a hash ref of expected op counts, check that
+ # for each opname => count pair, whether that op appears that many
+ # times in the op tree for that sub. If $debug is 1, display all the
+ # op counts for the sub.
+
+ sub test_opcount {
+ my ($debug, $desc, $coderef, $expected_counts) = @_;
+
+ %counts = ();
+ B::walkoptree(B::svref_2object($coderef)->ROOT,
+ 'test_opcount_callback');
+
+ if ($debug) {
+ note(sprintf "%3d %s", $counts{$_}, $_) for sort keys %counts;
+ }
+
+ for (sort keys %$expected_counts) {
+ is ($counts{$_}//0, $expected_counts->{$_}, "$desc: $_");
+ }
+ }
+}
+
+# aelem => aelemfast: a basic test that this test file works
+
+test_opcount(0, "basic aelemfast",
+ sub { $a[0] = 1 },
+ {
+ aelem => 0,
+ aelemfast => 1,
+ 'ex-aelem' => 1,
+ }
+ );
#!./perl
-# Use B to test that optimisations are not inadvertently removed.
+# Use B to test that optimisations are not inadvertently removed,
+# by examining particular nodes in the optree.
BEGIN {
chdir 't';
@INC = '../lib';
}
-plan 22;
+plan 23;
use v5.10; # state
use B qw 'svref_2object OPpASSIGN_COMMON';
}
+# list+pushmark in list context elided out of the execution chain
+is svref_2object(sub { () = ($_, ($_, $_)) })
+ ->START # nextstate
+ ->next # pushmark
+ ->next # gvsv
+ ->next # should be gvsv, not pushmark
+ ->name, 'gvsv',
+ "list+pushmark in list context where list's elder sibling is a null";
+
+
# nextstate multiple times becoming one nextstate
is svref_2object(sub { 0;0;0;0;0;0;time })->START->next->name, 'time',
--- /dev/null
+#!./perl
+#
+# All the tests in this file are ones that run exceptionally slowly
+# (each test taking seconds or even minutes) in the absence of particular
+# optimisations. Thus it is a sort of canary for optimisations being
+# broken.
+#
+# Although it includes a watchdog timeout, this is set to a generous limit
+# to allow for running on slow systems; therefore a broken optimisation
+# might be indicated merely by this test file taking unusually long to
+# run, rather than actually timing out.
+#
+
+use strict;
+use warnings;
+use 5.010;
+
+sub run_tests;
+
+$| = 1;
+
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = ('../lib');
+ require Config; import Config;
+ require './test.pl';
+}
+
+plan tests => 1;
+
+use warnings;
+use strict;
+
+watchdog(60);
+
+SKIP: {
+ # RT #121975 COW speedup lost after e8c6a474
+
+ # without COW, this test takes minutes; with COW, its less than a
+ # second
+ #
+ skip "PERL_NO_COW", 1 if $Config{ccflags} =~ /PERL_NO_COW/;
+
+ my ($x, $y);
+ $x = "x" x 1_000_000;
+ $y = $x for 1..1_000_000;
+ pass("COW 1Mb strings");
+}
+
+1;
my %files;
my $test_count = 0;
+# in a parallel 'make test', temporary files and directories can
+# randomly appear and disappear; don't complain about these
+no warnings 'File::Find';
+
find({no_chdir => 1, wanted => sub {
my $name = $File::Find::name;
# Assumes that the path separator is exactly one character.
skip_all( "Not all files are available during cross-compilation" );
}
-system "$^X Porting/checkcfgvar.pl --tap";
+system "$^X -Ilib Porting/checkcfgvar.pl --tap";
DB_File cpan/DB_File/DB_File.xs f364b661bbb0df075b0c425b104577e7176fe82b
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
+ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm 793813932194c12e62c6046f62ea6f1fb65de80b
IO::Socket::IP cpan/IO-Socket-IP/t/22timeout.t 0a65d4ca44663f70eea3c7f1ccb5faed2940611f
PerlIO::via::QuotedPrint cpan/PerlIO-via-QuotedPrint/t/QuotedPrint.t ca39f0146e89de02c746e199c45dcb3e5edad691
Socket cpan/Socket/t/getnameinfo.t f25ae4125d64a81538d4d3b73a3a0b9ce3c0404d
+Test::Simple cpan/Test-Simple/t/Legacy/exit.t 83edbf569d56d8cdbabea552dfe5602ea1c1822e
Text::Balanced cpan/Text-Balanced/t/01_compile.t 1598cf491a48fa546260a2ec41142abe84da533d
Text::Balanced cpan/Text-Balanced/t/02_extbrk.t 6ba1b64a4604e822dc2260b8ffcea6b406339ee8
Text::Balanced cpan/Text-Balanced/t/03_extcbk.t 3307c980af28963414cab799c427b359ef3b8657
foreach my $module ( sort keys %Modules ) {
next unless my $files = $Modules{ $module }{CUSTOMIZED};
+ next unless @{ $files };
my @perl_files = my_get_module_files( $module );
foreach my $file ( @perl_files ) {
my $digest = Digest->new( $digest_type );
curl(1)
Dancer
Data::Alias
+Data::Dump::Streamer
Data::Entropy
Data::Float
Data::Structure::Util
);
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.
- }
+ $expected{expl} = undef; # There is no Configure symbol for expl.
+} elsif ($Config{usequadmath}) {
+ $expected{expq} = undef; # There is no Configure symbol for expq.
} else {
$expected{exp} = undef; # There is no Configure symbol for exp.
}
use strict;
use warnings;
+no warnings 'locale'; # Plenty of these would otherwise get generated
use Encode;
use POSIX;
# the format supported by re/regexp.t. If you want to add a test
# that does fit that format, add it to re/re_tests, not here.
-use strict;
-use warnings;
-use 5.010;
-use Config;
-
sub run_tests;
$| = 1;
-
BEGIN {
chdir 't' if -d 't';
@INC = ('../lib','.');
skip_all_if_miniperl("miniperl can't load Tie::Hash::NamedCapture, need for %+ and %-");
}
+use strict;
+use warnings;
+use 5.010;
+use Config;
plan tests => 2532; # Update this when adding/deleting tests.
# test the same and that /\s/ and /\S/ are opposites, and that
# /[\s]/ and /[\S]/ are also opposites, for \s/\S and \d/\D and
# \w/\W.
-use strict;
-use warnings;
-use 5.010;
-
-
-sub run_tests;
-
-$| = 1;
-
BEGIN {
chdir 't' if -d 't';
require './test.pl';
}
+use strict;
+use warnings;
+use 5.010;
plan tests => 9; # Update this when adding/deleting tests.
+sub run_tests;
+
+$| = 1;
+
run_tests() unless caller;
#
# Make sure pos / resetting pos on failed match works
-use strict;
-use warnings;
-
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
plan tests => 8;
+use strict;
+use warnings;
+
## Early bailout of pp_match because matchlen > stringlen
# With a var
/(ab)+((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox
/(ab){1,100}((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox
/(ab){0,100}((?1))(fox)/ ababfox y $1-$2-$3 ab-ab-fox
+foo(?0)?bar phoofoofoobarbarbarr y $& foofoobarbar
+foo(?R)?bar phoofoofoobarbarbarr y $& foofoobarbar
# possessive captures
a++a aaaaa n - -
a*+a aaaaa n - -
'\Awibble\z'm wibble y - -
/(alias|status)es$/i Statuses y $1 Status # [perl #121778]
/( (?&solution) | % ) \Z (?(DEFINE) (?<solution>7\%\ solution) )/x 7% solution y $1 7% solution # [perl #122890]
+(.)(?{$~=$^N}) \x{100} y $~ \x{100} # [perl #123135]
# Keep these lines at the end of the file
# vim: softtabstop=0 noexpandtab
# with Perl_foo() verses the my_foo() under ext/re/ don't cause any
# changes.
-use strict;
-use warnings;
-
$| = 1;
-
BEGIN {
chdir 't' if -d 't';
@INC = ('../lib','.');
skip_all_if_miniperl("no dynamic loading on miniperl, no re");
}
+use strict;
+use warnings;
plan tests => 48;
'my $x = \'\m\'; qr/a$x/' => 'Unrecognized escape \m passed through {#} m/a\m{#}/',
'/\q/' => 'Unrecognized escape \q passed through {#} m/\q{#}/',
- # 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
+ # These two tests do not include the marker, because regcomp.c no
+ # longer knows where it goes by the time this warning is emitted.
+ # 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}{#}/',
+ '/(?=a){1,3}\x{100}/' => 'Quantifier unexpected on zero-length expression in regex m/(?=a){1,3}\x{100}/',
+ '/(a|b)(?=a){3}\x{100}/' => 'Quantifier unexpected on zero-length expression in regex m/(a|b)(?=a){3}\x{100}/',
'/\_/' => "",
'/[\_\0]/' => "",
# list of the constructed set and then comparing it character by character
# with the expected result.
-use strict;
-use warnings;
-
-$| = 1;
-
BEGIN {
chdir 't' if -d 't';
@INC = ('../lib','.','../ext/re');
skip_all_without_unicode_tables();
}
+use strict;
+use warnings;
+
+$| = 1;
+
use utf8;
no warnings 'experimental::regex_sets';
# The tests are in a separate file 't/re/re_tests'.
# Each line in that file is a separate test.
# There are five columns, separated by tabs.
+# An optional sixth column is used to give a reason, only when skipping tests
#
# Column 1 contains the pattern, optionally enclosed in C<''>.
# Modifiers can be put after the closing C<'>.
# t test exposes a bug with threading, TODO if qr_embed_thr
# s test should only be run for regex_sets_compat.t
# S test should not be run for regex_sets_compat.t
+# a test should only be run on ASCII platforms
+# e test should only be run on EBCDIC platforms
#
# Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
#
#
# Note that columns 2,3 and 5 are all enclosed in double quotes and then
# evalled; so something like a\"\x{100}$1 has length 3+length($1).
+#
+# \x... and \o{...} constants are automatically converted to the native
+# character set if necessary. \[0-7] constants aren't
my ($file, $iters);
BEGIN {
map { split /\n/ } @_;
}
+sub convert_from_ascii {
+ my $string = shift;
+
+ #my $save = $string;
+ # Convert \x{...}, \o{...}
+ $string =~ s/ (?<! \\ ) \\x\{ ( .*? ) } / "\\x{" . sprintf("%X", utf8::unicode_to_native(hex $1)) . "}" /gex;
+ $string =~ s/ (?<! \\ ) \\o\{ ( .*? ) } / "\\o{" . sprintf("%o", utf8::unicode_to_native(oct $1)) . "}" /gex;
+
+ # Convert \xAB
+ $string =~ s/ (?<! \\ ) \\x ( [A-Fa-f0-9]{2} ) / "\\x" . sprintf("%02X", utf8::unicode_to_native(hex $1)) /gex;
+
+ # Convert \xA
+ $string =~ s/ (?<! \\ ) \\x ( [A-Fa-f0-9] ) (?! [A-Fa-f0-9] ) / "\\x" . sprintf("%X", utf8::unicode_to_native(hex $1)) /gex;
+
+ #print STDERR __LINE__, ": $save\n$string\n" if $save ne $string;
+ return $string;
+}
+
use strict;
use warnings FATAL=>"all";
use vars qw($bang $ffff $nulnul); # used by the tests
}
$reason = '' unless defined $reason;
my $input = join(':',$pat,$subject,$result,$repl,$expect);
+
# the double '' below keeps simple syntax highlighters from going crazy
$pat = "'$pat'" unless $pat =~ /^[:''\/]/;
$pat =~ s/(\$\{\w+\})/$1/eeg;
$pat =~ s/\\n/\n/g unless $regex_sets;
+ $pat = convert_from_ascii($pat) if ord("A") != 65;
+
+ $subject = convert_from_ascii($subject) if ord("A") != 65;
$subject = eval qq("$subject"); die $@ if $@;
+
+ $expect = convert_from_ascii($expect) if ord("A") != 65;
$expect = eval qq("$expect"); die $@ if $@;
$expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
+
my $todo_qr = $qr_embed_thr && ($result =~ s/t//);
my $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
++$skip if $result =~ s/M// && !defined &DynaLoader::boot_DynaLoader;
$reason = "Test not valid for $0";
}
}
+ if ($result =~ s/a// && ord("A") != 65) {
+ $skip++;
+ $reason = "Test is only valid for ASCII platforms. $reason";
+ }
+ if ($result =~ s/e// && ord("A") != 193) {
+ $skip++;
+ $reason = "Test is only valid for EBCDIC platforms. $reason";
+ }
$reason = 'skipping $&' if $reason eq '' && $skip_amp;
$result =~ s/B//i unless $skip;
my $todo= $result =~ s/T// ? " # TODO" : "";
if (! $skip && $regex_sets) {
# If testing regex sets, change the [bracketed] classes into
- # (?[bracketed]).
-
- if ($pat !~ / \[ /x) {
-
+ # (?[bracketed]). But note that '\[' and '\c[' don't introduce such a
+ # class. (We don't bother looking for an odd number of backslashes,
+ # as this hasn't been needed so far.)
+ if ($pat !~ / (?<!\\c) (?<!\\) \[ /x) {
$skip++;
$reason = "Pattern doesn't contain [brackets]";
}
@INC = ('../lib','.','../ext/re');
require './test.pl';
if (is_miniperl()) {
- skip_if_miniperl("Unicode tables not built yet", 2)
+ skip_all_if_miniperl("Unicode tables not built yet", 2)
unless eval 'require "unicore/Heavy.pl"';
}
}
# run, rather than actually timing out.
#
-use strict;
-use warnings;
-use 5.010;
-
-sub run_tests;
-
-$| = 1;
-
-
BEGIN {
chdir 't' if -d 't';
@INC = ('../lib','.','../ext/re');
plan tests => 9; # Update this when adding/deleting tests.
+use strict;
+use warnings;
+use 5.010;
+
+sub run_tests;
+
+$| = 1;
+
run_tests() unless caller;
#
BEGIN {
chdir 't' if -d 't';
@INC = qw(../lib lib);
+ require "./test.pl";
}
-BEGIN { require "./test.pl"; }
-
# This test depends on t/lib/Devel/switchd*.pm.
plan(tests => 20);
'-d does not conflict with sort optimisations'
);
+SKIP: {
+ skip_if_miniperl("under miniperl", 1);
is(
runperl(
switches => [ '-Ilib', '-d:switchd_empty' ],
"debugged\n",
"\$DB::single set to overload"
);
+}
my $why = shift;
my $n = @_ ? shift : 1;
my $bad_swap;
+ my $both_zero;
{
local $^W = 0;
$bad_swap = $why > 0 && $n == 0;
+ $both_zero = $why == 0 && $n == 0;
}
- if ($bad_swap || @_) {
- my $arg = "$why, '$n'";
+ if ($bad_swap || $both_zero || @_) {
+ my $arg = "'$why', '$n'";
if (@_) {
$arg .= join(", ", '', map { qq['$_'] } @_);
}
}
sub skip_without_dynamic_extension {
- my ($extension) = @_;
- skip("no dynamic loading on miniperl, no $extension") if is_miniperl();
- return if &_have_dynamic_extension;
- skip("$extension was not built");
+ my $extension = shift;
+ skip("no dynamic loading on miniperl, no extension $extension", @_)
+ if is_miniperl();
+ return if &_have_dynamic_extension($extension);
+ skip("extension $extension was not built", @_);
}
sub todo_skip {
{
# [perl 16843]
my $line = 'abcdefghijklmnopqrstuvwxyz$0123456789';
- $line =~ tr/bcdeghijklmnprstvwxyz$02578/בצדעגהיײקלמנפּרסטװשכיזשױתײחא/;
+ $line =~ tr/bcdeghijklmnprstvwxyz$02578/בצדעגהיײקלמנפּרסטװשכיזשױתײח/;
is($line, "aבצדעfגהיײקלמנoפqּרסuטװשכיזש1ױ34ת6ײח9", "[perl #16843]");
}
BEGIN {
chdir 't' if -d 't';
require './test.pl';
+ skip_all_if_miniperl("miniperl, no arybase");
skip_all_without_unicode_tables();
}
use open qw( :utf8 :std );
no warnings qw(misc reserved);
-plan (tests => 65880);
+plan (tests => 66900);
-# ${single:colon} should not be valid syntax
+# ${single:colon} should not be treated as a simple variable, but as a
+# block with a label inside.
{
no strict;
local $@;
- eval "\${\x{30cd}single:\x{30cd}colon} = 1";
- like($@,
- qr/syntax error .* near "\x{30cd}single:/,
- '${\x{30cd}single:\x{30cd}colon} should not be valid syntax'
- );
+ eval "\${\x{30cd}single:\x{30cd}colon} = 'label, not var'";
+ is ${"\x{30cd}colon"}, 'label, not var',
+ '${\x{30cd}single:\x{30cd}colon} should be block-label';
local $@;
no utf8;
- evalbytes '${single:colon} = 1';
- like($@,
- qr/syntax error .* near "single:/,
+ evalbytes '${single:colon} = "block/label, not var"';
+ is($::colon,
+ 'block/label, not var',
'...same with ${single:colon}'
);
}
local $@;
eval "use utf8; \$$v;";
- is $@, '', "No syntax error for \$$v under use utf8";
+ is $@, '', "No syntax error for \$$v under 'use utf8'";
}
}
# Checking if the Latin-1 range behaves as expected, and that the behavior is the
# same whenever under strict or not.
-for ( 0x80..0xff ) {
+for ( 0x0 .. 0xff ) {
+ my @warnings;
+ local $SIG {__WARN__} = sub {push @warnings, @_ };
+ my $ord = utf8::unicode_to_native($_);
+ my $chr = chr $ord;
+ my $syntax_error = 0; # Do we expect this code point to generate a
+ # syntax error? Assume not, for now
+ my $deprecated = 0;
+ my $name;
+
+ # A different number of tests are run depending on the branches in this
+ # loop iteration. This allows us to add skips to make the reported total
+ # the same for each iteration.
+ my $tests = 0;
+ my $max_tests = 6;
+
+ if ($chr =~ /[[:graph:]]/a) {
+ $name = "'$chr'";
+ $syntax_error = 1 if $chr eq '{';
+ }
+ elsif ($chr =~ /[[:space:]]/a) {
+ $name = sprintf "\\x%02x, an ASCII space character", $ord;
+ $syntax_error = 1;
+ }
+ elsif ($chr =~ /[[:cntrl:]]/a) {
+ if ($chr eq "\N{NULL}") {
+ $name = sprintf "\\x%02x, NUL", $ord;
+ $syntax_error = 1;
+ }
+ else {
+ $name = sprintf "\\x%02x, an ASCII control", $ord;
+ $syntax_error = $::IS_EBCDIC;
+ $deprecated = ! $syntax_error;
+ }
+ }
+ elsif ($chr =~ /\pC/) {
+ if ($chr eq "\N{SHY}") {
+ $name = sprintf "\\x%02x, SHY", $ord;
+ }
+ else {
+ $name = sprintf "\\x%02x, a C1 control", $ord;
+ }
+ $syntax_error = $::IS_EBCDIC;
+ $deprecated = ! $syntax_error;
+ }
+ elsif ($chr =~ /\p{XIDStart}/) {
+ $name = sprintf "\\x%02x, a non-ASCII XIDS character", $ord;
+ }
+ elsif ($chr =~ /\p{XPosixSpace}/) {
+ $name = sprintf "\\x%02x, a non-ASCII space character", $ord;
+ $syntax_error = $::IS_EBCDIC;
+ $deprecated = ! $syntax_error;
+ }
+ else {
+ $name = sprintf "\\x%02x, a non-ASCII, non-XIDS graphic character", $ord;
+ }
no warnings 'closure';
- my $chr = chr;
- my $esc = sprintf("%X", ord $chr);
+ my $esc = sprintf("%X", $ord);
utf8::downgrade($chr);
if ($chr !~ /\p{XIDS}/u) {
- is evalbytes "no strict; \$$chr = 10",
- 10,
- sprintf("\\x%02x, part of the latin-1 range, is legal as a length-1 variable", $_);
-
- utf8::upgrade($chr);
- local $@;
- eval "no strict; use utf8; \$$chr = 1";
- like $@,
- qr/\QUnrecognized character \x{\E\L$esc/,
- sprintf("..but is illegal as a length-1 variable under use utf8", $_);
+ if ($syntax_error) {
+ evalbytes "\$$chr";
+ like($@, qr/ syntax\ error | Unrecognized\ character /x,
+ "$name as a length-1 variable generates a syntax error");
+ $tests++;
+ }
+ elsif ($ord < 32 || $chr =~ /[[:punct:][:digit:]]/a) {
+
+ # Unlike other variables, we dare not try setting the length-1
+ # variables that are \cX (for all valid X) nor ASCII ones that are
+ # punctuation nor digits. This is because many of these variables
+ # have meaning to the system, and setting them could have side
+ # effects or not work as expected (And using fresh_perl() doesn't
+ # always help.) For example, setting $^D (to use a visible
+ # representation of code point 0x04) turns on tracing, and setting
+ # $^E sets an error number, but what gets printed is instead a
+ # string associated with that number. For all these we just
+ # verify that they don't generate a syntax error.
+ local $@;
+ evalbytes "\$$chr;";
+ is $@, '', "$name as a length-1 variable doesn't generate a syntax error";
+ $tests++;
+ utf8::upgrade($chr);
+ evalbytes "no strict; use utf8; \$$chr;",
+ is $@, '', " ... and the same under 'use utf8'";
+ $tests++;
+ }
+ else {
+ is evalbytes "no strict; \$$chr = 10",
+ 10,
+ "$name is legal as a length-1 variable";
+ $tests++;
+ if ($chr =~ /[[:ascii:]]/) {
+ utf8::upgrade($chr);
+ is evalbytes "no strict; use utf8; \$$chr = 1",
+ 1,
+ " ... and is legal under 'use utf8'";
+ $tests++;
+ }
+ else {
+ utf8::upgrade($chr);
+ local $@;
+ eval "no strict; use utf8; \$$chr = 1";
+ like $@,
+ qr/\QUnrecognized character \x{\E\L$esc/,
+ " ... but is illegal as a length-1 variable under 'use utf8'";
+ $tests++;
+ }
+ }
}
else {
{
no utf8;
local $@;
evalbytes "no strict; \$$chr = 1";
- is($@, '', sprintf("\\x%02x, =~ \\p{XIDS}, latin-1, no utf8, no strict, is a valid length-1 variable", $_));
-
- local $@;
- evalbytes "use strict; \$$chr = 1";
- is($@,
- '',
- sprintf("\\x%02x under no utf8 does not have to be required under strict, even though it matches XIDS", $_)
- );
-
- local $@;
- evalbytes "\$a$chr = 1";
- like($@,
- qr/Unrecognized character /,
- sprintf("...but under no utf8, it's not allowed in two-or-more character variables")
- );
-
- local $@;
- evalbytes "\$a$chr = 1";
- like($@,
- qr/Unrecognized character /,
- sprintf("...but under no utf8, it's not allowed in two-or-more character variables")
- );
+ is($@, '', "$name under 'no utf8', 'no strict', is a valid length-1 variable");
+ $tests++;
+
+ if ($chr !~ /[[:ascii:]]/) {
+ local $@;
+ evalbytes "use strict; \$$chr = 1";
+ is($@,
+ '',
+ " ... and under 'no utf8' does not have to be required under strict, even though it matches XIDS"
+ );
+ $tests++;
+
+ local $@;
+ evalbytes "\$a$chr = 1";
+ like($@,
+ qr/Unrecognized character /,
+ " ... but under 'no utf8', it's not allowed in length-2+ variables"
+ );
+ $tests++;
+ }
}
{
use utf8;
- my $u = $chr;
- utf8::upgrade($u);
+ my $utf8 = $chr;
+ utf8::upgrade($utf8);
local $@;
- eval "no strict; \$$u = 1";
- is($@, '', sprintf("\\x%02x, =~ \\p{XIDS}, UTF-8, use utf8, no strict, is a valid length-1 variable", $_));
+ eval "no strict; \$$utf8 = 1";
+ is($@, '', " ... and under 'use utf8', 'no strict', is a valid length-1 variable");
+ $tests++;
local $@;
- eval "use strict; \$$u = 1";
- like($@,
- qr/Global symbol "\$$u" requires explicit package name/,
- sprintf("\\x%02x under utf8 has to be required under strict", $_)
- );
+ eval "use strict; \$$utf8 = 1";
+ if ($chr =~ /[ab]/) { # These are special, for sort()
+ is($@, '', " ... and under 'use utf8', 'use strict',"
+ . " is a valid length-1 variable (\$a and \$b are special)");
+ $tests++;
+ }
+ else {
+ like($@,
+ qr/Global symbol "\$$utf8" requires explicit package name/,
+ " ... and under utf8 has to be required under strict"
+ );
+ $tests++;
+ }
}
}
+
+ if (! $deprecated) {
+ if ($chr =~ /[#*]/) {
+
+ # Length-1 variables with these two characters used to be used by
+ # Perl, but now their generates a warning that they're gone.
+ # Ignore such warnings.
+ for (my $i = @warnings - 1; $i >= 0; $i--) {
+ splice @warnings, $i, 1 if $warnings[$i] =~ /is no longer supported/;
+ }
+ }
+ ok(@warnings == 0, " ... and doesn't generate any warnings");
+ $tests++;
+ }
+ elsif (! @warnings) {
+ fail(" ... and generates deprecation warnings (since is deprecated)");
+ $tests++;
+ }
+ else {
+ ok((scalar @warnings == grep { $_ =~ /deprecated/ } @warnings),
+ " ... and generates deprecation warnings (only)");
+ $tests++;
+ }
+
+ SKIP: {
+ die "Wrong max count for tests" if $tests > $max_tests;
+ skip("untaken tests", $max_tests - $tests) if $max_tests > $tests;
+ }
}
{
use utf8;
my $ret = eval "my \$c\x{327} = 100; \$c\x{327}"; # c + cedilla
is($@, '', "ASCII character + combining character works as a variable name");
- is($ret, 100, "...and returns the correct value");
+ is($ret, 100, " ... and returns the correct value");
}
# From Tom Christiansen's 'highly illegal variable names are now accidentally legal' mail
no warnings 'deprecated';
for my $var ( '$', "\7LOBAL_PHASE", "^GLOBAL_PHASE", "^V" ) {
+ SKIP: {
+ skip("Literal control characters in variable names forbidden on EBCDIC", 3)
+ if ($::IS_EBCDIC && ord substr($var, 0, 1) < 32);
eval "\${ $var}";
is($@, '', "\${ $var} works" );
eval "\${$var }";
is($@, '', "\${$var } works" );
eval "\${ $var }";
is($@, '', "\${ $var } works" );
+ }
}
}
}
);
- is(
- "".eval "*{^JOIN}",
- "*main::\nOIN",
- "...but \$^J is still legal"
- );
+ SKIP: {
+ skip('Is $^U on EBCDIC 1047, BC; nothing works on 0037', 1)
+ if $::IS_EBCDIC;
+ is(
+ "".eval "*{^JOIN}",
+ "*main::\nOIN",
+ " ... but \$^J is still legal"
+ );
+ }
+ SKIP: {
+ skip("Literal control characters in variable names forbidden on EBCDIC", 2)
+ if $::IS_EBCDIC;
no warnings 'deprecated';
my $ret = eval "\${\cT\n}";
is($@, "", 'No errors from using ${\n\cT\n}');
- is($ret, $^T, "...and we got the right value");
+ is($ret, $^T, " ... and we got the right value");
+ }
}
-{
+SKIP: {
+ skip("Literal control characters in variable names forbidden on EBCDIC", 5)
+ if $::IS_EBCDIC;
+
# Originally from t/base/lex.t, moved here since we can't
# turn deprecation warnings off in that file.
no strict;
);
eval "\$\cQ = 24"; # Literal control character
- is($@, "", "...and they can be assigned to without error");
- is(${"\cQ"}, 24, "...and the assignment works");
- is($^Q, 24, "...even if we access the variable through the caret name");
+ is($@, "", " ... and they can be assigned to without error");
+ is(${"\cQ"}, 24, " ... and the assignment works");
+ is($^Q, 24, " ... even if we access the variable through the caret name");
is(\${"\cQ"}, \$^Q, '\${\cQ} == \$^Q');
}
note "want: $expect";
note "got : $_";
}
- ok($expect eq $_);
+ ok($expect eq $_, $comment // '');
}
}
close $T;
['" "', 'a" "b" "c', "abc"],
);
-print "1.." . (@commands * @av * 2) . "\n";
+print "1.." . (@commands * @av * 3) . "\n";
for my $cmds (@commands) {
for my $args (@av) {
my @all_args;
}
}
$^D = 0;
+
+ note "# pipe [".join(";", @cmds, @args). "]";
+ if (open my $io, "|-", @cmds, @args) {
+ print <$io>;
+ close $io;
+ }
+ else {
+ print "Failed pipe open: $!\n";
+ }
}
}
#define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
#define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
-#define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
+#define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
#define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
#define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
#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 FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
-#define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
-#define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
-#define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
-#define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
+#define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
+#define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
+#define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
+#define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (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 Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (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 Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (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_yylval.ival = OP_DORASSIGN;
toketype = ASSIGNOP;
}
- return toketype;
+ return REPORT(toketype);
}
/*
OPERATOR(HASHBRACK);
}
if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
- /* ${...} or @{...} etc., but not print {...} */
- PL_expect = XTERM;
- break;
+ /* ${...} or @{...} etc., but not print {...}
+ * Skip the disambiguation and treat this as a block.
+ */
+ goto block_expectation;
}
/* This hack serves to disambiguate a pair of curlies
* as being a block or an anon hash. Normally, expectation
|| (*t == '=' && t[1] == '>')))
OPERATOR(HASHBRACK);
if (PL_expect == XREF)
- PL_expect = XTERM;
+ {
+ block_expectation:
+ /* If there is an opening brace or 'sub:', treat it
+ as a term to make ${{...}}{k} and &{sub:attr...}
+ dwim. Otherwise, treat it as a statement, so
+ map {no strict; ...} works.
+ */
+ s = skipspace(s);
+ if (*s == '{') {
+ PL_expect = XTERM;
+ break;
+ }
+ if (strnEQ(s, "sub", 3)) {
+ d = s + 3;
+ d = skipspace(d);
+ if (*d == ':') {
+ PL_expect = XTERM;
+ break;
+ }
+ }
+ PL_expect = XSTATE;
+ }
else {
PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
PL_expect = XSTATE;
break;
}
pl_yylval.ival = CopLINE(PL_curcop);
- if (isSPACE(*s) || *s == '#')
- PL_copline = NOLINE; /* invalidate current command line number */
+ PL_copline = NOLINE; /* invalidate current command line number */
TOKEN(formbrack ? '=' : '{');
case '}':
if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
}
case KEY___SUB__:
- FUN0OP(newPVOP(OP_RUNCV,0,NULL));
+ FUN0OP(CvCLONE(PL_compcv)
+ ? newOP(OP_RUNCV, 0)
+ : newPVOP(OP_RUNCV,0,NULL));
case KEY_AUTOLOAD:
case KEY_DESTROY:
/* Is the byte 'd' a legal single character identifier name? 'u' is true
* iff Unicode semantics are to be used. The legal ones are any of:
- * a) ASCII digits
- * b) ASCII punctuation
+ * a) all ASCII characters except:
+ * 1) space-type ones, like \t and SPACE;
+ 2) NUL;
+ * 3) '{'
+ * The final case currently doesn't get this far in the program, so we
+ * don't test for it. If that were to change, it would be ok to allow it.
* c) When not under Unicode rules, any upper Latin1 character
- * d) \c?, \c\, \c^, \c_, and \cA..\cZ, minus the ones that have traditionally
- * been matched by \s on ASCII platforms. That is: \c?, plus 1-32, minus
- * the \s ones. */
-#define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)(d)) \
- || isDIGIT_A((U8)(d)) \
- || (!(u) && !isASCII((U8)(d))) \
- || ((((U8)(d)) < 32) \
- && (((((U8)(d)) >= 14) \
- || (((U8)(d)) <= 8 && (d) != 0) \
- || (((U8)(d)) == 13)))) \
- || (((U8)(d)) == toCTRL('?')))
- if (s < PL_bufend
- && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(*s, is_utf8)))
+ * d) Otherwise, when unicode rules are used, all XIDS characters.
+ *
+ * Because all ASCII characters have the same representation whether
+ * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
+ * '{' without knowing if is UTF-8 or not */
+#ifdef EBCDIC
+# define VALID_LEN_ONE_IDENT(s, is_utf8) \
+ (isGRAPH_A(*(s)) || ((is_utf8) \
+ ? isIDFIRST_utf8((U8*) (s)) \
+ : (isGRAPH_L1(*s) \
+ && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
+#else
+# define VALID_LEN_ONE_IDENT(s, is_utf8) (! isSPACE_A(*(s)) \
+ && LIKELY(*(s) != '\0') \
+ && (! is_utf8 \
+ || isASCII_utf8((U8*) (s)) \
+ || isIDFIRST_utf8((U8*) (s))))
+#endif
+ if ((s <= PL_bufend - (is_utf8)
+ ? UTF8SKIP(s)
+ : 1)
+ && VALID_LEN_ONE_IDENT(s, is_utf8))
{
- if ( isCNTRL_A((U8)*s) ) {
- deprecate("literal control characters in variable names");
+ /* Deprecate all non-graphic characters. Include SHY as a non-graphic,
+ * because often it has no graphic representation. (We can't get to
+ * here with SHY when 'is_utf8' is true, so no need to include a UTF-8
+ * test for it.) */
+ if ((is_utf8)
+ ? ! isGRAPH_utf8( (U8*) s)
+ : (! isGRAPH_L1( (U8) *s)
+ || UNLIKELY((U8) *(s) == LATIN1_TO_NATIVE(0xAD))))
+ {
+ /* Split messages for back compat */
+ if (isCNTRL_A( (U8) *s)) {
+ deprecate("literal control characters in variable names");
+ }
+ else {
+ deprecate("literal non-graphic characters in variable names");
+ }
}
if (is_utf8) {
origline + 1 + PL_parser->herelines);
if (!lex_next_chunk(LEX_NO_TERM)
&& (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
- SvREFCNT_dec(linestr_save);
+ /* Simply freeing linestr_save might seem simpler here, as it
+ does not matter what PL_linestr points to, since we are
+ about to croak; but in a quote-like op, linestr_save
+ will have been prospectively freed already, via
+ SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
+ restore PL_linestr. */
+ SvREFCNT_dec_NN(PL_linestr);
+ PL_linestr = linestr_save;
goto interminable;
}
CopLINE_set(PL_curcop, origline);
CvFLAGS(PL_compcv) |= flags;
PL_subline = CopLINE(PL_curcop);
- CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
+ CvPADLIST_set(PL_compcv, pad_new(padnew_SAVE|padnew_SAVESUB));
CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
if (outsidecv && CvPADLIST(outsidecv))
PL_in_eval |= EVAL_WARNONLY;
yyerror_pv(s, flags);
- PL_in_eval &= ~EVAL_WARNONLY;
return 0;
}
PL_multi_end = 0;
}
if (PL_in_eval & EVAL_WARNONLY) {
+ PL_in_eval &= ~EVAL_WARNONLY;
Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
}
else
scalar(newUNOP(OP_RV2AV, 0,
newGVOP(OP_GV, 0, PL_defgv))),
newSVOP(OP_CONST, 0, newSViv(1))),
- newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
- newSVOP(OP_CONST, 0,
- newSVpvs("Odd name/value argument "
- "for subroutine"))));
+ op_convert_list(OP_DIE, 0,
+ op_convert_list(OP_SPRINTF, 0,
+ op_append_list(OP_LIST,
+ newSVOP(OP_CONST, 0,
+ newSVpvs("Odd name/value argument for subroutine at %s line %d.\n")),
+ newSLICEOP(0,
+ op_append_list(OP_LIST,
+ newSVOP(OP_CONST, 0, newSViv(1)),
+ newSVOP(OP_CONST, 0, newSViv(2))),
+ newOP(OP_CALLER, 0))))));
if (pos != min_arity)
chkop = newLOGOP(OP_AND, 0,
newBINOP(OP_GT, 0,
scalar(newUNOP(OP_RV2AV, 0,
newGVOP(OP_GV, 0, PL_defgv))),
newSVOP(OP_CONST, 0, newSViv(min_arity))),
- newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
- newSVOP(OP_CONST, 0,
- newSVpvs("Too few arguments for subroutine"))))),
+ op_convert_list(OP_DIE, 0,
+ op_convert_list(OP_SPRINTF, 0,
+ op_append_list(OP_LIST,
+ newSVOP(OP_CONST, 0,
+ newSVpvs("Too few arguments for subroutine at %s line %d.\n")),
+ newSLICEOP(0,
+ op_append_list(OP_LIST,
+ newSVOP(OP_CONST, 0, newSViv(1)),
+ newSVOP(OP_CONST, 0, newSViv(2))),
+ newOP(OP_CALLER, 0))))))),
initops);
}
if (max_arity != -1) {
scalar(newUNOP(OP_RV2AV, 0,
newGVOP(OP_GV, 0, PL_defgv))),
newSVOP(OP_CONST, 0, newSViv(max_arity))),
- newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
- newSVOP(OP_CONST, 0,
- newSVpvs("Too many arguments for subroutine"))))),
+ op_convert_list(OP_DIE, 0,
+ op_convert_list(OP_SPRINTF, 0,
+ op_append_list(OP_LIST,
+ newSVOP(OP_CONST, 0,
+ newSVpvs("Too many arguments for subroutine at %s line %d.\n")),
+ newSLICEOP(0,
+ op_append_list(OP_LIST,
+ newSVOP(OP_CONST, 0, newSViv(1)),
+ newSVOP(OP_CONST, 0, newSViv(2))),
+ newOP(OP_CALLER, 0))))))),
initops);
}
return initops;
*/
/*#define HAS_MUNMAP / **/
+/* HAS_NAN:
+ * This symbol, if defined, indicates that the nan routine is
+ * available to generate NaN.
+ */
+/*#define HAS_NAN / **/
+
+/* HAS_NEARBYINT:
+ * This symbol, if defined, indicates that the nextafter routine is
+ * available to return the integral value closest to (according to
+ the current rounding mode) to x.
+ */
+/*#define HAS_NEARBYINT / **/
+
+/* HAS_NEXTAFTER:
+ * This symbol, if defined, indicates that the nextafter routine is
+ * available to return the next machine representable long double from
+ * x in direction y.
+ */
+/*#define HAS_NEXTAFTER / **/
+
+/* HAS_NEXTTOWARD:
+ * This symbol, if defined, indicates that the nexttoward routine is
+ * available to return the next machine representable long double from
+ * x in direction y.
+ */
+/*#define HAS_NEXTTOWARD / **/
+
/* HAS_NICE:
* This symbol, if defined, indicates that the nice routine is
* available.
*/
/*#define HAS_READLINK / **/
+/* HAS_REMAINDER:
+ * This symbol, if defined, indicates that the remainder routine is available.
+ */
+/*#define HAS_REMAINDER / **/
+
+/* HAS_REMQUO:
+ * This symbol, if defined, indicates that the remquo routine is available.
+ */
+/*#define HAS_REMQUO / **/
+
/* HAS_RENAME:
* This symbol, if defined, indicates that the rename routine is available
* to rename files. Otherwise you should do the unlink(), link(), unlink()
*/
#define HAS_RENAME /**/
+/* HAS_RINT:
+ * This symbol, if defined, indicates that the rint routine is available
+ * to return the nearest integral value to x as double using the current
+ * rounding mode.
+ */
+/*#define HAS_RINT / **/
+
/* HAS_RMDIR:
* This symbol, if defined, indicates that the rmdir routine is
* available to remove directories. Otherwise you should fork off a
*/
/*#define HAS_RMDIR / **/
+/* HAS_ROUND:
+ * This symbol, if defined, indicates that the round routine is available.
+ */
+/*#define HAS_ROUND / **/
+
/* HAS_SELECT:
* This symbol, if defined, indicates that the select routine is
* available to select active file descriptors. If the timeout field
*/
/*#define HAS_TCSETPGRP / **/
+/* HAS_TGAMMA:
+ * This symbol, if defined, indicates that the lgamma routine is
+ * available to do the gamma function. See also HAS_LGAMMA.
+ */
+/*#define HAS_TGAMMA / **/
+
/* HAS_TRUNCATE:
* This symbol, if defined, indicates that the truncate routine is
* available to truncate files.
*/
#define DOUBLESIZE 8 /**/
+/* DOUBLEKIND:
+ * DOUBLEKIND will be one of
+ * DOUBLE_IS_IEEE_754_32_BIT_LITTLE_ENDIAN
+ * DOUBLE_IS_IEEE_754_32_BIT_BIG_ENDIAN
+ * DOUBLE_IS_IEEE_754_64_BIT_LITTLE_ENDIAN
+ * DOUBLE_IS_IEEE_754_64_BIT_BIG_ENDIAN
+ * DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
+ * DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN
+ * DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE
+ * DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE
+ * DOUBLE_IS_UNKNOWN_FORMAT
+ */
+#define DOUBLEKIND 3 /**/
+#define DOUBLE_IS_IEEE_754_32_BIT_LITTLE_ENDIAN 1
+#define DOUBLE_IS_IEEE_754_32_BIT_BIG_ENDIAN 2
+#define DOUBLE_IS_IEEE_754_64_BIT_LITTLE_ENDIAN 3
+#define DOUBLE_IS_IEEE_754_64_BIT_BIG_ENDIAN 4
+#define DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN 5
+#define DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN 6
+#define DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE 7
+#define DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE 8
+#define DOUBLE_IS_UNKNOWN_FORMAT -1
+
/* EBCDIC:
* This symbol, if defined, indicates that this system uses
* EBCDIC encoding.
*/
/*#define HAS_ACOSH / **/
+/* HAS_ASINH:
+ * This symbol, if defined, indicates that the asinh routine is
+ * available to do the inverse hyperbolic sine function.
+ */
+/*#define HAS_ASINH / **/
+
+/* HAS_ATANH:
+ * This symbol, if defined, indicates that the atanh routine is
+ * available to do the inverse hyperbolic tangent function.
+ */
+/*#define HAS_ATANH / **/
+
+/* HAS_CBRT:
+ * This symbol, if defined, indicates that the cbrt routine is
+ * available to do the cubic root function.
+ */
+/*#define HAS_CBRT / **/
+
+/* HAS_COPYSIGN:
+ * This symbol, if defined, indicates that the copysign routine is
+ * available to do the copysign function.
+ */
+/*#define HAS_COPYSIGN / **/
+
+/* HAS_ERF:
+ * This symbol, if defined, indicates that the erf routine is
+ * available to do the error function.
+ */
+/*#define HAS_ERF / **/
+
+/* HAS_ERFC:
+ * This symbol, if defined, indicates that the erfc routine is
+ * available to do the complementary error function.
+ */
+/*#define HAS_ERFC / **/
+
+/* HAS_EXP2:
+ * This symbol, if defined, indicates that the exp2 routine is
+ * available to do the 2**x function.
+ */
+/*#define HAS_EXP2 / **/
+
+/* HAS_EXPM1:
+ * This symbol, if defined, indicates that the expm1 routine is
+ * available to do the exp(x) - 1 when x is near 1.
+ */
+/*#define HAS_EXPM1 / **/
+
+/* HAS_FMA:
+ * This symbol, if defined, indicates that the fma routine is
+ * available to do the multiply-add function.
+ */
+/*#define HAS_FMA / **/
+
+/* HAS_FDIM:
+ * This symbol, if defined, indicates that the fdim routine is
+ * available to do the positive difference function.
+ */
+/*#define HAS_FDIM / **/
+
+/* HAS_FMAX:
+ * This symbol, if defined, indicates that the fma routine is
+ * available to do the maximum function.
+ */
+/*#define HAS_FMAX / **/
+
+/* HAS_FMIN:
+ * This symbol, if defined, indicates that the fma routine is
+ * available to do the minimum function.
+ */
+/*#define HAS_FMIN / **/
+
/* HAS_AINTL:
* This symbol, if defined, indicates that the aintl routine is
* available. If copysignl is also present we can emulate modfl.
*/
/*#define HAS_HASMNTOPT / **/
+/* HAS_HYPOT:
+ * This symbol, if defined, indicates that the hypot routine is
+ * available to do the hypotenuse function.
+ */
+/*#define HAS_HYPOT / **/
+
+/* HAS_ILOGB:
+ * This symbol, if defined, indicates that the ilogb routine is
+ * available.
+ */
+/*#define HAS_ILOGB / **/
+
/* HAS_ILOGBL:
* This symbol, if defined, indicates that the ilogbl routine is
* available. If scalbnl is also present we can emulate frexpl.
*/
/*#define HAS_ISNANL / **/
+/* HAS_ISNORMAL:
+ * This symbol, if defined, indicates that the isnormal routine is
+ * available to check whether a double is normal (non-zero normalized).
+ */
+/*#define HAS_ISNORMAL / **/
+
/* HAS_J0:
* This symbol, if defined, indicates to the C program that the
* j0() function is available for Bessel functions of the first
*/
/*#define HAS_LDBL_DIG / * */
+/* HAS_LGAMMA:
+ * This symbol, if defined, indicates that the lgamma routine is
+ * available to do the log gamma function. See also HAS_TGAMMA and
+ * HAS_LGAMMA_R.
+ */
+/*#define HAS_LGAMMA / **/
+
+/* HAS_LGAMMA_R:
+ * This symbol, if defined, indicates that the lgamma_r routine is
+ * available to do the log gamma function without using the global
+ * signgam variable.
+ */
+/*#define HAS_LGAMMA_R / **/
+
/* LIBM_LIB_VERSION:
* This symbol, if defined, indicates that libm exports _LIB_VERSION
* and that math.h defines the enum to manipulate it.
*/
/*#define LIBM_LIB_VERSION / **/
+/* HAS_LLRINT:
+ * This symbol, if defined, indicates that the llrint routine is
+ * available to return the closest long long value according to
+ * the current rounding mode.
+ */
+/*#define HAS_LLRINT / **/
+
+/* HAS_LLROUND:
+ * This symbol, if defined, indicates that the llround routine is
+ * available to return the nearest long long value.
+ */
+/*#define HAS_LLROUND / **/
+
+/* HAS_LOG1P:
+ * This symbol, if defined, indicates that the lgamma routine is
+ * available to do the log1p function.
+ */
+/*#define HAS_LOG1P / **/
+
+/* HAS_LOG2:
+ * This symbol, if defined, indicates that the lgamma routine is
+ * available to do the log2 function.
+ */
+/*#define HAS_LOG2 / **/
+
+/* HAS_LOGB:
+ * This symbol, if defined, indicates that the lgamma routine is
+ * available to do the logb function.
+ */
+/*#define HAS_LOGB / **/
+
+/* HAS_LRINT:
+ * This symbol, if defined, indicates that the lrint routine is
+ * available to return the closest integral value according to
+ * the current rounding mode.
+ */
+/*#define HAS_LRINT / **/
+
+/* HAS_LROUND:
+ * This symbol, if defined, indicates that the lround routine is
+ * available to return the nearest integral value.
+ */
+/*#define HAS_LROUND / **/
+
/* HAS_MADVISE:
* This symbol, if defined, indicates that the madvise system call is
* available to map a file into memory.
*/
/*#define HAS_SBRK_PROTO / **/
+/* HAS_SCALBN:
+ * This symbol, if defined, indicates that the scalbn routine is available.
+ */
+/*#define HAS_SCALBN / **/
+
/* HAS_SCALBNL:
* This symbol, if defined, indicates that the scalbnl routine is
* available. If ilogbl is also present we can emulate frexpl.
*/
/*#define HAS_TIMEGM / **/
+/* HAS_TRUNC:
+ * This symbol, if defined, indicates that the trunc routine is available.
+ */
+/*#define HAS_TRUNC / **/
+
/* HAS_TRUNCL:
* This symbol, if defined, indicates that the truncl routine is
* available. If copysignl is also present we can emulate modfl.
#endif
/* Generated from:
- * 60aff40735c73cdf11d3fbae8088eadf73c0b45413be5bd8480ec5ec481066da config_h.SH
- * 35023b2d9244ad2dc3abea4bb5174a7f66398b60266231cb9a2c3bfc8df867cf uconfig.sh
+ * 7c85f69913f492fecfaef3ab68fba849dc01a6b917c88c66991f06fa1ef53797 config_h.SH
+ * 22822d456ad16d8f6b30a42bfa66aab6d7b264993ad6c95ecbf385c3a87c8826 uconfig.sh
* ex: set ro: */
d_archlib='undef'
d_asctime64='undef'
d_asctime_r='undef'
+d_asinh='undef'
+d_atanh='undef'
d_atolf='undef'
d_atoll='undef'
d_attribute_deprecated='undef'
d_c99_variadic_macros='undef'
d_casti32='undef'
d_castneg='undef'
+d_cbrt='undef'
d_charvspr='undef'
d_chown='undef'
d_chroot='undef'
d_closedir='define'
d_cmsghdr_s='undef'
d_const='undef'
+d_copysign='undef'
d_copysignl='undef'
d_cplusplus='undef'
d_crypt='undef'
d_endsent='undef'
d_endservent_r='undef'
d_eofnblk='undef'
+d_erf='undef'
+d_erfc='undef'
d_eunice='undef'
+d_exp2='undef'
+d_expm1='undef'
d_faststdio='undef'
d_fchdir='undef'
d_fchmod='undef'
d_fcntl_can_lock='undef'
d_fd_macros='undef'
d_fd_set='undef'
+d_fdim='undef'
d_fds_bits='undef'
d_fegetround='undef'
d_fgetpos='undef'
d_flexfnam='undef'
d_flock='undef'
d_flockproto='undef'
+d_fma='undef'
+d_fmax='undef'
+d_fmin='undef'
d_fork='define'
d_fp_class='undef'
d_fp_classify='undef'
d_grpasswd='undef'
d_hasmntopt='undef'
d_htonl='undef'
+d_hypot='undef'
+d_ilogb='undef'
d_ilogbl='undef'
d_inc_version_list='undef'
d_index='undef'
d_isinfl='undef'
d_isnan='undef'
d_isnanl='undef'
+d_isnormal='undef'
d_j0='undef'
d_j0l='undef'
d_killpg='undef'
d_lchown='undef'
d_ldbl_dig='undef'
d_ldexpl='undef'
+d_lgamma='undef'
+d_lgamma_r='undef'
d_libm_lib_version='undef'
d_link='undef'
+d_llrint='undef'
+d_llround='undef'
d_localtime64='undef'
d_localtime_r='undef'
d_localtime_r_needs_tzset='undef'
d_locconv='undef'
d_lockf='undef'
+d_log1p='undef'
+d_log2='undef'
+d_logb='undef'
d_longdbl='undef'
d_longlong='undef'
+d_lrint='undef'
+d_lround='undef'
d_lseekproto='undef'
d_lstat='undef'
d_madvise='undef'
d_msync='undef'
d_munmap='undef'
d_mymalloc='undef'
+d_nan='undef'
d_ndbm_h_uses_prototypes='undef'
+d_nearbyint='undef'
+d_nextafter='undef'
+d_nexttoward='undef'
d_nice='undef'
d_nl_langinfo='undef'
d_nv_preserves_uv='undef'
d_readlink='undef'
d_readv='undef'
d_recvmsg='undef'
+d_remainder='undef'
+d_remquo='undef'
d_rename='define'
d_rewinddir='undef'
+d_rint='undef'
d_rmdir='undef'
+d_round='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='undef'
d_sbrkproto='undef'
+d_scalbn='undef'
d_scalbnl='undef'
d_sched_yield='undef'
d_scm_rights='undef'
d_tcsetpgrp='undef'
d_telldir='undef'
d_telldirproto='undef'
+d_tgamma='undef'
d_time='define'
d_timegm='undef'
d_times='undef'
d_tm_tm_gmtoff='undef'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
+d_trunc='undef'
d_truncate='undef'
d_truncl='undef'
d_ttyname_r='undef'
db_version_minor='0'
db_version_patch='0'
direntrytype='struct dirent'
+doublekind='3'
doublesize='8'
drand01="Perl_drand48()"
drand48_r_proto='0'
d_archlib='undef'
d_asctime64='undef'
d_asctime_r='undef'
+d_asinh='undef'
+d_atanh='undef'
d_atolf='undef'
d_atoll='undef'
d_attribute_deprecated='undef'
d_c99_variadic_macros='undef'
d_casti32='undef'
d_castneg='undef'
+d_cbrt='undef'
d_charvspr='undef'
d_chown='undef'
d_chroot='undef'
d_closedir='define'
d_cmsghdr_s='undef'
d_const='undef'
+d_copysign='undef'
d_copysignl='undef'
d_cplusplus='undef'
d_crypt='undef'
d_endsent='undef'
d_endservent_r='undef'
d_eofnblk='undef'
+d_erf='undef'
+d_erfc='undef'
d_eunice='undef'
+d_exp2='undef'
+d_expm1='undef'
d_faststdio='undef'
d_fchdir='undef'
d_fchmod='undef'
d_fcntl_can_lock='undef'
d_fd_macros='undef'
d_fd_set='undef'
+d_fdim='undef'
d_fds_bits='undef'
d_fegetround='undef'
d_fgetpos='undef'
d_flexfnam='undef'
d_flock='undef'
d_flockproto='undef'
+d_fma='undef'
+d_fmax='undef'
+d_fmin='undef'
d_fork='define'
d_fp_class='undef'
d_fp_classify='undef'
d_grpasswd='undef'
d_hasmntopt='undef'
d_htonl='undef'
+d_hypot='undef'
+d_ilogb='undef'
d_ilogbl='undef'
d_inc_version_list='undef'
d_index='undef'
d_isinfl='undef'
d_isnan='undef'
d_isnanl='undef'
+d_isnormal='undef'
d_j0='undef'
d_j0l='undef'
d_killpg='undef'
d_lchown='undef'
d_ldbl_dig='undef'
d_ldexpl='undef'
+d_lgamma='undef'
+d_lgamma_r='undef'
d_libm_lib_version='undef'
d_link='undef'
+d_llrint='undef'
+d_llround='undef'
d_localtime64='undef'
d_localtime_r='undef'
d_localtime_r_needs_tzset='undef'
d_locconv='undef'
d_lockf='undef'
+d_log1p='undef'
+d_log2='undef'
+d_logb='undef'
d_longdbl='undef'
d_longlong='undef'
+d_lrint='undef'
+d_lround='undef'
d_lseekproto='undef'
d_lstat='undef'
d_madvise='undef'
d_msync='undef'
d_munmap='undef'
d_mymalloc='undef'
+d_nan='undef'
d_ndbm_h_uses_prototypes='undef'
+d_nearbyint='undef'
+d_nextafter='undef'
+d_nexttoward='undef'
d_nice='undef'
d_nl_langinfo='undef'
d_nv_preserves_uv='undef'
d_readlink='undef'
d_readv='undef'
d_recvmsg='undef'
+d_remainder='undef'
+d_remquo='undef'
d_rename='define'
d_rewinddir='undef'
+d_rint='undef'
d_rmdir='undef'
+d_round='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='undef'
d_sbrkproto='undef'
+d_scalbn='undef'
d_scalbnl='undef'
d_sched_yield='undef'
d_scm_rights='undef'
d_tcsetpgrp='undef'
d_telldir='undef'
d_telldirproto='undef'
+d_tgamma='undef'
d_time='define'
d_timegm='undef'
d_times='undef'
d_tm_tm_gmtoff='undef'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
+d_trunc='undef'
d_truncate='undef'
d_truncl='undef'
d_ttyname_r='undef'
db_version_minor='0'
db_version_patch='0'
direntrytype='struct dirent'
+doublekind='3'
doublesize='8'
drand01="((rand() & 0x7FFF) / (double) ((unsigned long)1 << 15))"
drand48_r_proto='0'
{
CV * const cv =
newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL);
- Safefree(CvFILE(cv));
- CvFILE(cv) = (char *)file;
+ char ** cvfile = &CvFILE(cv);
+ char * oldfile = *cvfile;
CvDYNFILE_off(cv);
+ *cvfile = (char *)file;
+ Safefree(oldfile);
}
}
return d;
}
+#ifdef EBCDIC
+ /* Not representable in UTF-EBCDIC */
+ flags |= UNICODE_DISALLOW_FE_FF;
+#endif
+
/* The first problematic code point is the first surrogate */
if (uv >= UNICODE_SURROGATE_FIRST
&& ckWARN3_d(WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR))
if (flags & UNICODE_DISALLOW_SUPER
|| (UNICODE_IS_FE_FF(uv) && (flags & UNICODE_DISALLOW_FE_FF)))
{
+#ifdef EBCDIC
+ Perl_die(aTHX_ "Can't represent character for Ox%"UVXf" on this platform", uv);
+ assert(0);
+#endif
return NULL;
}
}
if (! PL_utf8_perl_idstart) {
invlist = _new_invlist_C_array(_Perl_IDStart_invlist);
}
- return is_utf8_common(p, &PL_utf8_perl_idstart, "", invlist);
+ return is_utf8_common(p, &PL_utf8_perl_idstart, "_Perl_IDStart", invlist);
}
bool
if (! PL_utf8_perl_idcont) {
invlist = _new_invlist_C_array(_Perl_IDCont_invlist);
}
- return is_utf8_common(p, &PL_utf8_perl_idcont, "", invlist);
+ return is_utf8_common(p, &PL_utf8_perl_idcont, "_Perl_IDCont", invlist);
}
bool
}
STATIC UV
-S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
+S_check_locale_boundary_crossing(pTHX_ const char * const func_name, const U8* const p, const UV result, U8* const ustrp, STRLEN *lenp)
{
/* This is called when changing the case of a utf8-encoded character above
* the Latin1 range, and the operation is in a non-UTF-8 locale. If the
/* Failed, have to return the original */
original = valid_utf8_to_uvchr(p, lenp);
+
+ /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
+ Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
+ "Can't do %s(\"\\x{%"UVXf"}\") on non-UTF-8 locale; "
+ "resolved to \"\\x{%"UVXf"}\".",
+ func_name,
+ original,
+ original);
Copy(p, ustrp, *lenp, char);
return original;
}
result = CALL_UPPER_CASE(p, ustrp, lenp);
if (flags) {
- result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+ result = check_locale_boundary_crossing("uc", p, result, ustrp, lenp);
}
return result;
}
result = CALL_TITLE_CASE(p, ustrp, lenp);
if (flags) {
- result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+ result = check_locale_boundary_crossing("ucfirst", p, result, ustrp, lenp);
}
return result;
}
result = CALL_LOWER_CASE(p, ustrp, lenp);
if (flags) {
- result = check_locale_boundary_crossing(p, result, ustrp, lenp);
+ result = check_locale_boundary_crossing("lc", p, result, ustrp, lenp);
}
return result;
&& memEQ((char *) p, LATIN_CAPITAL_LETTER_SHARP_S_UTF8,
sizeof(LATIN_CAPITAL_LETTER_SHARP_S_UTF8) - 1))
{
+ /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
+ Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
+ "Can't do fc(\"\\x{1E9E}\") on non-UTF-8 locale; "
+ "resolved to \"\\x{17F}\\x{17F}\".");
goto return_long_s;
}
else if (UTF8SKIP(p) == sizeof(LATIN_SMALL_LIGATURE_LONG_S_T) - 1
&& memEQ((char *) p, LATIN_SMALL_LIGATURE_LONG_S_T_UTF8,
sizeof(LATIN_SMALL_LIGATURE_LONG_S_T_UTF8) - 1))
{
+ /* diag_listed_as: Can't do %s("%s") on non-UTF-8 locale; resolved to "%s". */
+ Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
+ "Can't do fc(\"\\x{FB05}\") on non-UTF-8 locale; "
+ "resolved to \"\\x{FB06}\".");
goto return_ligature_st;
}
- return check_locale_boundary_crossing(p, result, ustrp, lenp);
+ return check_locale_boundary_crossing("fc", p, result, ustrp, lenp);
}
else if (! (flags & FOLD_FLAGS_NOMIX_ASCII)) {
return result;
#define UTF8_TWO_BYTE_HI(c) \
(__ASSERT_((sizeof(c) == 1) \
|| !(((WIDEST_UTYPE)(c)) & ~MAX_PORTABLE_UTF8_TWO_BYTE)) \
- ((U8) __BASE_TWO_BYTE_HI(c, NATIVE_TO_LATIN1)))
+ ((U8) __BASE_TWO_BYTE_HI(c, NATIVE_TO_UNI)))
#define UTF8_TWO_BYTE_LO(c) \
(__ASSERT_((sizeof(c) == 1) \
|| !(((WIDEST_UTYPE)(c)) & ~MAX_PORTABLE_UTF8_TWO_BYTE)) \
- ((U8) __BASE_TWO_BYTE_LO(c, NATIVE_TO_LATIN1)))
+ ((U8) __BASE_TWO_BYTE_LO(c, NATIVE_TO_UNI)))
/* This is illegal in any well-formed UTF-8 in both EBCDIC and ASCII
* as it is only in overlongs. */
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
#ifdef USE_MDH
- where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
+ Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
{
struct perl_memory_debug_header *const header
- = (struct perl_memory_debug_header *)where;
+ = (struct perl_memory_debug_header *)where_intrn;
# ifdef MDH_HAS_SIZE
const MEM_SIZE size = header->size;
maybe_protect_ro(header->prev);
maybe_protect_rw(header);
# ifdef PERL_POISON
- PoisonNew(where, size, char);
+ PoisonNew(where_intrn, size, char);
# endif
/* Trigger the duplicate free warning. */
header->next = NULL;
# endif
# ifdef PERL_DEBUG_READONLY_COW
- if (munmap(where, size)) {
+ if (munmap(where_intrn, size)) {
perror("munmap failed");
abort();
}
# endif
}
-#endif
+#else
+ Malloc_t where_intrn = where;
+#endif /* USE_MDH */
#ifndef PERL_DEBUG_READONLY_COW
- PerlMem_free(where);
+ PerlMem_free(where_intrn);
#endif
}
}
}
}
-char *
-Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
-{
- PERL_ARGS_ASSERT_SCREAMINSTR;
- PERL_UNUSED_ARG(bigstr);
- PERL_UNUSED_ARG(littlestr);
- PERL_UNUSED_ARG(start_shift);
- PERL_UNUSED_ARG(end_shift);
- PERL_UNUSED_ARG(old_posp);
- PERL_UNUSED_ARG(last);
-
- /* This function must only ever be called on a scalar with study magic,
- but those do not happen any more. */
- Perl_croak(aTHX_ "panic: screaminstr");
- NORETURN_FUNCTION_END;
-}
-
/*
=for apidoc foldEQ
=cut
*/
+#ifdef _MSC_VER
+# pragma warning( push )
+# pragma warning( disable : 4646 ) /* warning C4646: function declared with
+ __declspec(noreturn) has non-void return type */
+# pragma warning( disable : 4645 ) /* warning C4645: function declared with
+__declspec(noreturn) has a return statement */
+#endif
OP *
Perl_die_sv(pTHX_ SV *baseex)
{
assert(0); /* NOTREACHED */
NORETURN_FUNCTION_END;
}
+#ifdef _MSC_VER
+# pragma warning( pop )
+#endif
/*
=for apidoc Am|OP *|die|const char *pat|...
*/
#if defined(PERL_IMPLICIT_CONTEXT)
+#ifdef _MSC_VER
+# pragma warning( push )
+# pragma warning( disable : 4646 ) /* warning C4646: function declared with
+ __declspec(noreturn) has non-void return type */
+# pragma warning( disable : 4645 ) /* warning C4645: function declared with
+__declspec(noreturn) has a return statement */
+#endif
OP *
Perl_die_nocontext(const char* pat, ...)
{
va_end(args);
NORETURN_FUNCTION_END;
}
+#ifdef _MSC_VER
+# pragma warning( pop )
+#endif
#endif /* PERL_IMPLICIT_CONTEXT */
+#ifdef _MSC_VER
+# pragma warning( push )
+# pragma warning( disable : 4646 ) /* warning C4646: function declared with
+ __declspec(noreturn) has non-void return type */
+# pragma warning( disable : 4645 ) /* warning C4645: function declared with
+__declspec(noreturn) has a return statement */
+#endif
OP *
Perl_die(pTHX_ const char* pat, ...)
{
va_end(args);
NORETURN_FUNCTION_END;
}
+#ifdef _MSC_VER
+# pragma warning( pop )
+#endif
/*
=for apidoc Am|void|croak_sv|SV *baseex
PerlLIO_close(pp[0]);
return PerlIO_fdopen(p[This], mode);
#else
-# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
+# if defined(OS2) /* Same, without fork()ing and all extra overhead... */
return my_syspopen4(aTHX_ NULL, mode, n, args);
+# elif defined(WIN32)
+ return win32_popenlist(mode, n, args);
# else
Perl_croak(aTHX_ "List form of piped open not implemented");
return (PerlIO *) NULL;
#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
#endif /* PERL_IMPLICIT_CONTEXT */
+
+/* The meaning of the varargs is determined U32 key arg. This is not a format
+ string. The U32 key is assembled with HS_KEY.
+
+ v_my_perl arg is "PerlInterpreter * my_perl" if PERL_IMPLICIT_CONTEXT and
+ otherwise "CV * cv" (boot xsub's CV *). v_my_perl will catch where a threaded
+ future perl526.dll calling IO.dll for example, and IO.dll was linked with
+ threaded perl524.dll, and both perl526.dll and perl524.dll are in %PATH and
+ the Win32 DLL loader sucessfully can load IO.dll into the process but
+ simultaniously it loaded a interp of a different version into the process,
+ and XS code will naturally pass SV*s created by perl524.dll for perl526.dll
+ to use through perl526.dll's my_perl->Istack_base.
+
+ v_my_perl (v=void) can not be the first arg since then key will be out of
+ place in a threaded vs non-threaded mixup and analyzing the key number's
+ bitfields won't reveal the problem since it will be a valid key
+ (unthreaded perl) on interp side, but croak reports the XS mod's key as
+ gibberish (it is really my_perl ptr) (threaded XS mod), or if threaded perl
+ and unthreaded XS module, threaded perl will look at uninit C stack or uninit
+ register to get var key (remember it assumes 1st arg is interp cxt).
+
+Perl_xs_handshake(U32 key, void * v_my_perl, const char * file,
+[U32 items, U32 ax], [char * api_version], [char * xs_version]) */
+I32
+Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
+{
+ va_list args;
+ U32 items, ax;
+ void * got;
+ void * need;
+#ifdef PERL_IMPLICIT_CONTEXT
+ dTHX;
+ tTHX xs_interp;
+#else
+ CV* cv;
+ SV *** xs_spp;
+#endif
+ PERL_ARGS_ASSERT_XS_HANDSHAKE;
+ va_start(args, file);
+
+ got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH));
+ need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH);
+ if (UNLIKELY(got != need))
+ goto bad_handshake;
+/* try to catch where a 2nd threaded perl interp DLL is loaded into a process
+ by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the
+ 2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so
+ dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub
+ passed to the XS DLL */
+#ifdef PERL_IMPLICIT_CONTEXT
+ xs_interp = (tTHX)v_my_perl;
+ got = xs_interp;
+ need = my_perl;
+#else
+/* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is
+ loaded into a process by a XS DLL built by an unthreaded perl522.dll perl,
+ but the DynaLoder/Perl that started the process and loaded the XS DLL is
+ unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *)
+ through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's
+ location in the unthreaded perl binary) stored in CV * to figure out if this
+ Perl_xs_handshake was called by the same pp_entersub */
+ cv = (CV*)v_my_perl;
+ xs_spp = (SV***)CvHSCXT(cv);
+ got = xs_spp;
+ need = &PL_stack_sp;
+#endif
+ if(UNLIKELY(got != need)) {
+ bad_handshake:/* recycle branch and string from above */
+ if(got != (void *)HSf_NOCHK)
+ noperl_die("%s: Invalid handshake key got %p"
+ " needed %p, binaries are mismatched",
+ file, got, need);
+ }
+
+ if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */
+ SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
+ PL_xsubfilename = file; /* so the old name must be restored for
+ additional XSUBs to register themselves */
+ (void)gv_fetchfile(file);
+ }
+
+ if(key & HSf_POPMARK) {
+ ax = POPMARK;
+ { SV **mark = PL_stack_base + ax++;
+ { dSP;
+ items = (I32)(SP - MARK);
+ }
+ }
+ } else {
+ items = va_arg(args, U32);
+ ax = va_arg(args, U32);
+ }
+ {
+ U32 apiverlen;
+ assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX);
+ if((apiverlen = HS_GETAPIVERLEN(key))) {
+ char * api_p = va_arg(args, char*);
+ if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
+ || memNE(api_p, "v" PERL_API_VERSION_STRING,
+ sizeof("v" PERL_API_VERSION_STRING)-1))
+ Perl_croak_nocontext("Perl API version %s of %"SVf" does not match %s",
+ api_p, SVfARG(PL_stack_base[ax + 0]),
+ "v" PERL_API_VERSION_STRING);
+ }
+ }
+ {
+ U32 xsverlen;
+ assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX);
+ if((xsverlen = HS_GETXSVERLEN(key)))
+ Perl_xs_version_bootcheck(aTHX_
+ items, ax, va_arg(args, char*), xsverlen);
+ }
+ va_end(args);
+ return ax;
+}
+
void
Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
STRLEN xs_len)
}
}
-void
-Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
- STRLEN api_len)
-{
- SV *xpt = NULL;
- SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
- SV *runver;
-
- PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
-
- /* This might croak */
- compver = upg_version(compver, 0);
- /* This should never croak */
- runver = new_version(PL_apiversion);
- if (vcmp(compver, runver)) {
- SV *compver_string = vstringify(compver);
- SV *runver_string = vstringify(runver);
- xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
- " of %"SVf" does not match %"SVf,
- SVfARG(compver_string), SVfARG(module),
- SVfARG(runver_string));
- Perl_sv_2mortal(aTHX_ xpt);
-
- SvREFCNT_dec(compver_string);
- SvREFCNT_dec(runver_string);
- }
- SvREFCNT_dec(runver);
- if (xpt)
- Perl_croak_sv(aTHX_ xpt);
-}
-
/*
=for apidoc my_strlcat
#endif /* USE_C_BACKTRACE */
+/* Use a packed 32 bit constant "key" to start the handshake. The key defines
+ ABI compatibility, and how to process the vararg list.
+
+ Note, some bits may be taken from INTRPSIZE (but then a simple x86 AX register
+ can't be used to read it) and 4 bits from API version len can also be taken,
+ since v00.00.00 is 9 bytes long. XS version length should not have any bits
+ taken since XS_VERSION lengths can get quite long since they are user
+ selectable. These spare bits allow for additional features for the varargs
+ stuff or ABI compat test flags in the future.
+*/
+#define HSm_APIVERLEN 0x0000001F /* perl version string won't be more than 31 chars */
+#define HS_APIVERLEN_MAX HSm_APIVERLEN
+#define HSm_XSVERLEN 0x0000FF00 /* if 0, not present, dont check, die if over 255*/
+#define HS_XSVERLEN_MAX 0xFF
+/* uses var file to set default filename for newXS_deffile to use for CvFILE */
+#define HSf_SETXSUBFN 0x00000020
+#define HSf_POPMARK 0x00000040 /* popmark mode or you must supply ax and items */
+#define HSf_IMP_CXT 0x00000080 /* ABI, threaded/PERL_IMPLICIT_CONTEXT, pTHX_ present */
+#define HSm_INTRPSIZE 0xFFFF0000 /* ABI, interp struct size */
+/* A mask of bits in the key which must always match between a XS mod and interp.
+ Also if all ABI bits in a key are true, skip all ABI checks, it is very
+ the unlikely interp size will all 1 bits */
+/* Maybe HSm_APIVERLEN one day if Perl_xs_apiversion_bootcheck is changed to a memcmp */
+#define HSm_KEY_MATCH (HSm_INTRPSIZE|HSf_IMP_CXT)
+#define HSf_NOCHK HSm_KEY_MATCH /* if all ABI bits are 1 in the key, dont chk */
+
+
+#define HS_GETINTERPSIZE(key) ((key) >> 16)
+/* if in the future "" and NULL must be separated, XSVERLEN would be 0
+means arg not present, 1 is empty string/null byte */
+/* (((key) & 0x0000FF00) >> 8) is less efficient on Visual C */
+#define HS_GETXSVERLEN(key) ((key) >> 8 & 0xFF)
+#define HS_GETAPIVERLEN(key) ((key) & HSm_APIVERLEN)
+
+/* internal to util.h macro to create a packed handshake key, all args must be constants */
+/* U32 return = (U16 interpsize, bool cxt, bool setxsubfn, bool popmark,
+ U5 (FIVE!) apiverlen, U8 xsverlen) */
+#define HS_KEYp(interpsize, cxt, setxsubfn, popmark, apiverlen, xsverlen) \
+ (((interpsize) << 16) \
+ | ((xsverlen) > HS_XSVERLEN_MAX \
+ ? (Perl_croak_nocontext("panic: handshake overflow"), HS_XSVERLEN_MAX) \
+ : (xsverlen) << 8) \
+ | (cBOOL(setxsubfn) ? HSf_SETXSUBFN : 0) \
+ | (cBOOL(cxt) ? HSf_IMP_CXT : 0) \
+ | (cBOOL(popmark) ? HSf_POPMARK : 0) \
+ | ((apiverlen) > HS_APIVERLEN_MAX \
+ ? (Perl_croak_nocontext("panic: handshake overflow"), HS_APIVERLEN_MAX) \
+ : (apiverlen)))
+/* overflows above will optimize away unless they will execute */
+
+/* public macro for core usage to create a packed handshake key but this is
+ not public API. This more friendly version already collected all ABI info */
+/* U32 return = (bool setxsubfn, bool popmark, "litteral_string_api_ver",
+ "litteral_string_xs_ver") */
+#ifdef PERL_IMPLICIT_CONTEXT
+# define HS_KEY(setxsubfn, popmark, apiver, xsver) \
+ HS_KEYp(sizeof(PerlInterpreter), TRUE, setxsubfn, popmark, \
+ sizeof("" apiver "")-1, sizeof("" xsver "")-1)
+# define HS_CXT aTHX
+#else
+# define HS_KEY(setxsubfn, popmark, apiver, xsver) \
+ HS_KEYp(sizeof(struct PerlHandShakeInterpreter), FALSE, setxsubfn, popmark, \
+ sizeof("" apiver "")-1, sizeof("" xsver "")-1)
+# define HS_CXT cv
+#endif
+
/*
* Local variables:
* c-indentation-style: bsd
extra.pods : miniperl
@ @extra_pods.com
-PERLDELTA_CURRENT = [.pod]perl5215delta.pod
+PERLDELTA_CURRENT = [.pod]perl5216delta.pod
$(PERLDELTA_CURRENT) : [.pod]perldelta.pod
Copy/NoConfirm/Log $(MMS$SOURCE) $(PERLDELTA_CURRENT)
VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS);
}
}
- else *(cp1++) = *cp2;
+ else {
+ int out_cnt;
+ cp2 += copy_expand_unix_filename_escape(cp1, cp2, &out_cnt, utf8_flag);
+ cp2--; /* we're in a loop that will increment this */
+ cp1 += out_cnt;
+ }
infront = 1;
}
}
_ckvmssts_noperl(lib$find_file_end(&context));
}
-static int child_st[2];/* Event Flag set when child process completes */
-
-static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
-
-static unsigned long int exit_handler(void)
-{
-short iosb[4];
-
- if (0 == child_st[0])
- {
-#ifdef ARGPROC_DEBUG
- PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
-#endif
- fflush(stdout); /* Have to flush pipe for binary data to */
- /* terminate properly -- <tp@mccall.com> */
- sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
- sys$dassgn(child_chan);
- fclose(stdout);
- sys$synch(0, child_st);
- }
- return(1);
-}
-
-static void sig_child(int chan)
-{
-#ifdef ARGPROC_DEBUG
- PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
-#endif
- if (child_st[0] == 0)
- child_st[0] = 1;
-}
-
-static struct exit_control_block exit_block =
- {
- 0,
- exit_handler,
- 1,
- &exit_block.exit_status,
- 0
- };
static void
pipe_and_fork(pTHX_ char **cmargv)
#define COMPLEX_STATUS 1 /* We track both "POSIX" and VMS values */
-#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) & OPpHINT_M_VMSISH_MASK)
#ifdef PERL_IMPLICIT_CONTEXT
-# define TEST_VMSISH(h) (my_perl && PL_curcop && (PL_curcop->op_private & ((h) >> HINT_V_VMSISH)))
+# define TEST_VMSISH(h) (my_perl && PL_curcop && (PL_curcop->cop_hints & (h)))
#else
-# define TEST_VMSISH(h) (PL_curcop && (PL_curcop->op_private & ((h) >> HINT_V_VMSISH)))
+# define TEST_VMSISH(h) (PL_curcop && (PL_curcop->cop_hints & (h)))
#endif
#define VMSISH_STATUS TEST_VMSISH(HINT_M_VMSISH_STATUS)
#define VMSISH_TIME TEST_VMSISH(HINT_M_VMSISH_TIME)
#define WARN_EXPERIMENTAL__REFALIASING 60
#define WARN_EXPERIMENTAL__WIN32_PERLIO 61
-#define WARN_MISSING 62
-#define WARN_REDUNDANT 63
+#define WARN_LOCALE 62
+#define WARN_MISSING 63
+#define WARN_REDUNDANT 64
-#define WARNsize 16
-#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125"
-#define WARN_NONEstring "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
+#define WARNsize 17
+#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125"
+#define WARN_NONEstring "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
#
# Uncomment if you want to build a 32-bit Perl using a 32-bit compiler
# on a 64-bit version of Windows.
+#
#WIN64 = undef
#
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER = \5.21.5
+#INST_VER = \5.21.6
#
# Comment this out if you DON'T want your perl installation to have
# then get a number of fails from make test i.e. bugs - complain to them not us ;-).
# You will also be unable to take full advantage of perl5.8's support for multiple
# encodings and may see lower IO performance. You have been warned.
+#
USE_PERLIO = define
#
# Comment this out if you don't want to enable large file support for
# some reason. Should normally only be changed to maintain compatibility
# with an older release of perl.
+#
USE_LARGE_FILES = define
#
# (If you're building a 64-bit perl then you will have 64-bit integers whether
# or not this is uncommented.)
# Note: This option is not supported in 32-bit MSVC60 builds.
+#
#USE_64_BIT_INT = define
#
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5215delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5216delta.pod
cd ..\win32
$(PERLEXE) $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
-if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API
-if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS
-cd $(PODDIR) && del /f *.html *.bat roffitall \
- perl5215delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5216delta.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_archlib='define'
d_asctime64='undef'
d_asctime_r='undef'
+d_asinh='undef'
+d_atanh='undef'
d_atolf='undef'
d_atoll='undef'
d_attribute_deprecated='undef'
d_c99_variadic_macros='undef'
d_casti32='undef'
d_castneg='define'
+d_cbrt='undef'
d_charvspr='undef'
d_chown='undef'
d_chroot='undef'
d_closedir='define'
d_cmsghdr_s='undef'
d_const='define'
+d_copysign='undef'
d_copysignl='undef'
d_cplusplus='undef'
d_crypt='undef'
d_endservent_r='undef'
d_endspent='undef'
d_eofnblk='define'
+d_erf='undef'
+d_erfc='undef'
d_eunice='undef'
+d_exp2='undef'
+d_expm1='undef'
d_faststdio='undef'
d_fchdir='undef'
d_fchmod='undef'
d_fcntl_can_lock='undef'
d_fd_macros='define'
d_fd_set='define'
+d_fdim='undef'
d_fds_bits='define'
d_fegetround='undef'
d_fgetpos='define'
d_flexfnam='define'
d_flock='undef'
d_flockproto='undef'
+d_fma='undef'
+d_fmax='undef'
+d_fmin='undef'
d_fork='undef'
d_fp_class='undef'
d_fp_classify='undef'
d_grpasswd='undef'
d_hasmntopt='undef'
d_htonl='define'
+d_hypot='undef'
+d_ilogb='undef'
d_ilogbl='undef'
d_inc_version_list='undef'
d_index='undef'
d_isinfl='undef'
d_isnan='define'
d_isnanl='undef'
+d_isnormal='undef'
d_j0='undef'
d_j0l='undef'
d_killpg='undef'
d_lchown='undef'
d_ldbl_dig='define'
d_ldexpl='undef'
+d_lgamma='undef'
+d_lgamma_r='undef'
d_libm_lib_version='undef'
d_link='define'
+d_llrint='undef'
+d_llround='undef'
d_localtime64='undef'
d_localtime_r='undef'
d_localtime_r_needs_tzset='undef'
d_locconv='undef'
d_lockf='undef'
+d_log1p='undef'
+d_log2='undef'
+d_logb='undef'
d_longdbl='undef'
d_longlong='undef'
+d_lrint='undef'
+d_lround='undef'
d_lseekproto='define'
d_lstat='undef'
d_madvise='undef'
d_msync='undef'
d_munmap='undef'
d_mymalloc='~PERL_MALLOC~'
+d_nan='undef'
d_ndbm_h_uses_prototypes='undef'
+d_nearbyint='undef'
+d_nextafter='undef'
+d_nexttoward='undef'
d_nice='undef'
d_nl_langinfo='undef'
d_nv_preserves_uv='define'
d_readlink='undef'
d_readv='undef'
d_recvmsg='undef'
+d_remainder='undef'
+d_remquo='undef'
d_rename='define'
d_rewinddir='define'
+d_rint='undef'
d_rmdir='define'
+d_round='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='define'
d_sbrkproto='undef'
+d_scalbn='undef'
d_scalbnl='undef'
d_sched_yield='undef'
d_scm_rights='undef'
d_tcsetpgrp='undef'
d_telldir='define'
d_telldirproto='define'
+d_tgamma='undef'
d_time='define'
d_timegm='undef'
d_times='define'
d_tm_tm_gmtoff='undef'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
+d_trunc='undef'
d_truncate='undef'
d_truncl='undef'
d_ttyname_r='undef'
direntrytype='struct direct'
dlext='dll'
dlsrc='dl_win32.xs'
+doublekind='3'
doublesize='8'
drand01='Perl_drand48()'
drand48_r_proto='0'
d_PRIEUldbl='undef'
d_PRIFUldbl='undef'
d_PRIGUldbl='undef'
-d_PRIXU64='undef'
-d_PRId64='undef'
+d_PRIXU64='define'
+d_PRId64='define'
d_PRIeldbl='undef'
d_PRIfldbl='undef'
d_PRIgldbl='undef'
-d_PRIi64='undef'
-d_PRIo64='undef'
-d_PRIu64='undef'
-d_PRIx64='undef'
+d_PRIi64='define'
+d_PRIo64='define'
+d_PRIu64='define'
+d_PRIx64='define'
d_SCNfldbl='undef'
d__fwalk='undef'
d_access='define'
d_archlib='define'
d_asctime64='undef'
d_asctime_r='undef'
+d_asinh='undef'
+d_atanh='undef'
d_atolf='undef'
d_atoll='undef'
d_attribute_deprecated='undef'
d_c99_variadic_macros='undef'
d_casti32='define'
d_castneg='define'
+d_cbrt='undef'
d_charvspr='undef'
d_chown='undef'
d_chroot='undef'
d_closedir='define'
d_cmsghdr_s='undef'
d_const='define'
+d_copysign='undef'
d_copysignl='undef'
d_cplusplus='undef'
d_crypt='define'
d_endsent='undef'
d_endservent_r='undef'
d_eofnblk='define'
+d_erf='undef'
+d_erfc='undef'
d_eunice='undef'
+d_exp2='undef'
+d_expm1='undef'
d_faststdio='define'
d_fchdir='undef'
d_fchmod='undef'
d_fcntl_can_lock='undef'
d_fd_macros='define'
d_fd_set='define'
+d_fdim='undef'
d_fds_bits='define'
d_fegetround='undef'
d_fgetpos='define'
d_flexfnam='define'
d_flock='define'
d_flockproto='define'
+d_fma='undef'
+d_fmax='undef'
+d_fmin='undef'
d_fork='undef'
d_fp_class='undef'
d_fp_classify='undef'
d_grpasswd='undef'
d_hasmntopt='undef'
d_htonl='define'
+d_hypot='undef'
+d_ilogb='undef'
d_ilogbl='undef'
d_inc_version_list='undef'
d_index='undef'
d_isinfl='undef'
d_isnan='define'
d_isnanl='undef'
+d_isnormal='undef'
d_j0='undef'
d_j0l='undef'
d_killpg='define'
d_lchown='undef'
d_ldbl_dig='define'
d_ldexpl='undef'
+d_lgamma='undef'
+d_lgamma_r='undef'
d_libm_lib_version='undef'
d_link='define'
+d_llrint='undef'
+d_llround='undef'
d_localtime64='undef'
d_localtime_r='undef'
d_localtime_r_needs_tzset='undef'
d_locconv='define'
d_lockf='undef'
+d_log1p='undef'
+d_log2='undef'
+d_logb='undef'
d_longdbl='define'
d_longlong='define'
+d_lrint='undef'
+d_lround='undef'
d_lseekproto='define'
d_lstat='undef'
d_madvise='undef'
d_msync='undef'
d_munmap='undef'
d_mymalloc='undef'
+d_nan='undef'
d_ndbm='undef'
d_ndbm_h_uses_prototypes='undef'
+d_nearbyint='undef'
+d_nextafter='undef'
+d_nexttoward='undef'
d_nice='undef'
d_nl_langinfo='undef'
d_nv_preserves_uv='define'
d_readlink='undef'
d_readv='undef'
d_recvmsg='undef'
+d_remainder='undef'
+d_remquo='undef'
d_rename='define'
d_rewinddir='define'
+d_rint='undef'
d_rmdir='define'
+d_round='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='define'
d_sbrkproto='undef'
+d_scalbn='undef'
d_scalbnl='undef'
d_sched_yield='undef'
d_scm_rights='undef'
d_tcsetpgrp='undef'
d_telldir='define'
d_telldirproto='define'
+d_tgamma='undef'
d_time='define'
d_timegm='undef'
d_times='define'
d_tm_tm_gmtoff='undef'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
+d_trunc='undef'
d_truncate='undef'
d_truncl='undef'
d_ttyname_r='undef'
dlext='dll'
dlltool='~ARCHPREFIX~dlltool'
dlsrc='dl_win32.xs'
+doublekind='3'
doublesize='8'
drand01='Perl_drand48()'
drand48_r_proto='0'
sGMTIME_min="0"
sLOCALTIME_max="2147483647"
sLOCALTIME_min="0"
-sPRIEUldbl='"E"'
-sPRIFUldbl='"F"'
-sPRIGUldbl='"G"'
+sPRIEUldbl='"LE"'
+sPRIFUldbl='"LF"'
+sPRIGUldbl='"LG"'
sPRIXU64='"lX"'
sPRId64='"ld"'
-sPRIeldbl='"e"'
-sPRIfldbl='"f"'
-sPRIgldbl='"g"'
+sPRIeldbl='"Le"'
+sPRIfldbl='"Lf"'
+sPRIgldbl='"Lg"'
sPRIi64='"li"'
sPRIo64='"lo"'
sPRIu64='"lu"'
sPRIx64='"lx"'
-sSCNfldbl='"f"'
+sSCNfldbl='"Lf"'
sched_yield=''
scriptdir='~INST_TOP~~INST_VER~\bin'
scriptdirexp='~INST_TOP~~INST_VER~\bin'
d_PRIEUldbl='undef'
d_PRIFUldbl='undef'
d_PRIGUldbl='undef'
-d_PRIXU64='undef'
-d_PRId64='undef'
+d_PRIXU64='define'
+d_PRId64='define'
d_PRIeldbl='undef'
d_PRIfldbl='undef'
d_PRIgldbl='undef'
-d_PRIi64='undef'
-d_PRIo64='undef'
-d_PRIu64='undef'
-d_PRIx64='undef'
+d_PRIi64='define'
+d_PRIo64='define'
+d_PRIu64='define'
+d_PRIx64='define'
d_SCNfldbl='undef'
d__fwalk='undef'
d_access='define'
d_archlib='define'
d_asctime64='undef'
d_asctime_r='undef'
+d_asinh='undef'
+d_atanh='undef'
d_atolf='undef'
d_atoll='undef'
d_attribute_deprecated='undef'
d_c99_variadic_macros='undef'
d_casti32='undef'
d_castneg='define'
+d_cbrt='undef'
d_charvspr='undef'
d_chown='undef'
d_chroot='undef'
d_closedir='define'
d_cmsghdr_s='undef'
d_const='define'
+d_copysign='undef'
d_copysignl='undef'
d_cplusplus='undef'
d_crypt='define'
d_endsent='undef'
d_endservent_r='undef'
d_eofnblk='define'
+d_erf='undef'
+d_erfc='undef'
d_eunice='undef'
+d_exp2='undef'
+d_expm1='undef'
d_faststdio='define'
d_fchdir='undef'
d_fchmod='undef'
d_fcntl_can_lock='undef'
d_fd_macros='define'
d_fd_set='define'
+d_fdim='undef'
d_fds_bits='define'
d_fegetround='undef'
d_fgetpos='define'
d_flexfnam='define'
d_flock='define'
d_flockproto='define'
+d_fma='undef'
+d_fmax='undef'
+d_fmin='undef'
d_fork='undef'
d_fp_class='undef'
d_fp_classify='undef'
d_grpasswd='undef'
d_hasmntopt='undef'
d_htonl='define'
+d_hypot='undef'
+d_ilogb='undef'
d_ilogbl='undef'
d_inc_version_list='undef'
d_index='undef'
d_isinfl='undef'
d_isnan='define'
d_isnanl='undef'
+d_isnormal='undef'
d_j0='undef'
d_j0l='undef'
d_killpg='define'
d_lchown='undef'
d_ldbl_dig='define'
d_ldexpl='undef'
+d_lgamma='undef'
+d_lgamma_r='undef'
d_libm_lib_version='undef'
d_link='define'
+d_llrint='undef'
+d_llround='undef'
d_localtime64='undef'
d_localtime_r='undef'
d_localtime_r_needs_tzset='undef'
d_locconv='define'
d_lockf='undef'
+d_log1p='undef'
+d_log2='undef'
+d_logb='undef'
d_longdbl='define'
d_longlong='undef'
+d_lrint='undef'
+d_lround='undef'
d_lseekproto='define'
d_lstat='undef'
d_madvise='undef'
d_msync='undef'
d_munmap='undef'
d_mymalloc='undef'
+d_nan='undef'
d_ndbm='undef'
d_ndbm_h_uses_prototypes='undef'
+d_nearbyint='undef'
+d_nextafter='undef'
+d_nexttoward='undef'
d_nice='undef'
d_nl_langinfo='undef'
d_nv_preserves_uv='define'
d_readlink='undef'
d_readv='undef'
d_recvmsg='undef'
+d_remainder='undef'
+d_remquo='undef'
d_rename='define'
d_rewinddir='define'
+d_rint='undef'
d_rmdir='define'
+d_round='undef'
d_safebcpy='undef'
d_safemcpy='undef'
d_sanemcmp='define'
d_sbrkproto='undef'
+d_scalbn='undef'
d_scalbnl='undef'
d_sched_yield='undef'
d_scm_rights='undef'
d_tcsetpgrp='undef'
d_telldir='define'
d_telldirproto='define'
+d_tgamma='undef'
d_time='define'
d_timegm='undef'
d_times='define'
d_tm_tm_gmtoff='undef'
d_tm_tm_zone='undef'
d_tmpnam_r='undef'
+d_trunc='undef'
d_truncate='undef'
d_truncl='undef'
d_ttyname_r='undef'
direntrytype='struct direct'
dlext='dll'
dlsrc='dl_win32.xs'
+doublekind='3'
doublesize='8'
drand01='Perl_drand48()'
drand48_r_proto='0'
* This symbol, if defined, contains the string used by stdio to
* format long doubles (format 'f') for input.
*/
-/*#define PERL_PRIfldbl "f" / **/
-/*#define PERL_PRIgldbl "g" / **/
-/*#define PERL_PRIeldbl "e" / **/
-/*#define PERL_SCNfldbl "f" / **/
+/*#define PERL_PRIfldbl "Lf" / **/
+/*#define PERL_PRIgldbl "Lg" / **/
+/*#define PERL_PRIeldbl "Le" / **/
+/*#define PERL_SCNfldbl "Lf" / **/
/* NEED_VA_COPY:
* This symbol, if defined, indicates that the system stores
$opt{ssizetype} = 'int';
$opt{st_ino_size} = 4;
}
+
+# set 64-bit-int options
if ($opt{use64bitint} eq 'define') {
- $opt{d_nv_preserves_uv} = 'undef';
+ if ($opt{uselongdouble} eq 'define') {
+ $opt{d_nv_preserves_uv} = 'define';
+ $opt{nv_preserves_uv_bits} = 64;
+ }
+ else {
+ $opt{d_nv_preserves_uv} = 'undef';
+ $opt{nv_preserves_uv_bits} = 53;
+ }
$opt{ivdformat} = qq{"I64d"};
$opt{ivsize} = 8;
$opt{ivtype} = $int64;
- $opt{nv_preserves_uv_bits} = 53;
$opt{sPRIXU64} = qq{"I64X"};
$opt{sPRId64} = qq{"I64d"};
$opt{sPRIi64} = qq{"I64i"};
$opt{uvxformat} = '"lx"';
}
+# set long double options
+if ($opt{uselongdouble} eq 'define') {
+ $opt{d_Gconvert} = 'sprintf((b),"%.*""Lg",(n),(x))';
+ $opt{d_PRIEUldbl} = 'define';
+ $opt{d_PRIFUldbl} = 'define';
+ $opt{d_PRIGUldbl} = 'define';
+ $opt{d_frexpl} = 'define';
+ $opt{d_isnanl} = 'define';
+ $opt{d_modfl} = 'define';
+ $opt{d_modflproto} = 'define';
+ $opt{d_sqrtl} = 'define';
+ $opt{d_strtold} = 'define';
+ $opt{d_PRIeldbl} = 'define';
+ $opt{d_PRIfldbl} = 'define';
+ $opt{d_PRIgldbl} = 'define';
+ $opt{d_SCNfldbl} = 'define';
+ $opt{nvsize} = 12;
+ $opt{nvtype} = 'long double';
+ $opt{nv_overflows_integers_at} = '256.0*256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0*2.0*2.0*2.0';
+ $opt{nvEUformat} = '"LE"';
+ $opt{nvFUformat} = '"LF"';
+ $opt{nvGUformat} = '"LG"';
+ $opt{nveformat} = '"Le"';
+ $opt{nvfformat} = '"Lf"';
+ $opt{nvgformat} = '"Lg"';
+}
+else {
+ $opt{d_Gconvert} = 'sprintf((b),"%.*g",(n),(x))';
+ $opt{d_PRIEUldbl} = 'undef';
+ $opt{d_PRIFUldbl} = 'undef';
+ $opt{d_PRIGUldbl} = 'undef';
+ $opt{d_frexpl} = 'undef';
+ $opt{d_isnanl} = 'undef';
+ $opt{d_modfl} = 'undef';
+ $opt{d_modflproto} = 'undef';
+ $opt{d_sqrtl} = 'undef';
+ $opt{d_strtold} = 'undef';
+ $opt{d_PRIeldbl} = 'undef';
+ $opt{d_PRIfldbl} = 'undef';
+ $opt{d_PRIgldbl} = 'undef';
+ $opt{d_SCNfldbl} = 'undef';
+ $opt{nvsize} = 8;
+ $opt{nvtype} = 'double';
+ $opt{nv_overflows_integers_at} = '256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0';
+ $opt{nvEUformat} = '"E"';
+ $opt{nvFUformat} = '"F"';
+ $opt{nvGUformat} = '"G"';
+ $opt{nveformat} = '"e"';
+ $opt{nvfformat} = '"f"';
+ $opt{nvgformat} = '"g"';
+}
+
# change the s{GM|LOCAL}TIME_{min|max} for VS2005 (aka VC 8) and
# VS2008 (aka VC 9) or higher (presuming that later versions will have
# at least the range of that).
#
# Uncomment if you want to build a 32-bit Perl using a 32-bit compiler
# on a 64-bit version of Windows.
+#
#WIN64 *= undef
#
# versioned installation can be obtained by setting INST_TOP above to a
# path that includes an arbitrary version string.
#
-#INST_VER *= \5.21.5
+#INST_VER *= \5.21.6
#
# Comment this out if you DON'T want your perl installation to have
# then get a number of fails from make test i.e. bugs - complain to them not us ;-).
# You will also be unable to take full advantage of perl5.8's support for multiple
# encodings and may see lower IO performance. You have been warned.
+#
USE_PERLIO *= define
#
# Comment this out if you don't want to enable large file support for
# some reason. Should normally only be changed to maintain compatibility
# with an older release of perl.
+#
USE_LARGE_FILES *= define
#
# (If you're building a 64-bit perl then you will have 64-bit integers whether
# or not this is uncommented.)
# Note: This option is not supported in 32-bit MSVC60 builds.
+#
#USE_64_BIT_INT *= define
#
+# Uncomment this if you want to support the use of long doubles in GCC builds.
+# This option is not supported for MSVC builds.
+#
+#USE_LONG_DOUBLE *=define
+
+#
# uncomment exactly one of the following
#
# Visual C++ 6.x (aka Visual C++ 98)
USE_PERLIO *= undef
USE_LARGE_FILES *= undef
USE_64_BIT_INT *= undef
+USE_LONG_DOUBLE *= undef
.IF "$(USE_IMP_SYS)" == "define"
PERL_MALLOC = undef
USE_64_BIT_INT != undef
.ENDIF
+# Disable the long double option for MSVC builds since that compiler
+# does not support it.
+.IF "$(CCTYPE)" != "GCC"
+USE_LONG_DOUBLE != undef
+.ENDIF
+
ARCHITECTURE = $(PROCESSOR_ARCHITECTURE)
.IF "$(ARCHITECTURE)" == "AMD64"
ARCHITECTURE = x64
IMPLIB = $(ARCHPREFIX)dlltool
RSC = $(ARCHPREFIX)windres
+.IF "$(USE_LONG_DOUBLE)" == "define"
+BUILDOPT += -D__USE_MINGW_ANSI_STDIO
+MINIBUILDOPT += -D__USE_MINGW_ANSI_STDIO
+.ENDIF
+
GCCWRAPV *= $(shell for /f "delims=. tokens=1,2,3" %i in ('$(CC) -dumpversion') do @if "%i"=="4" (if "%j" geq "3" echo define) else if "%i" geq "5" (echo define))
.IF "$(GCCWRAPV)" == "define"
usemultiplicity=$(USE_MULTI) ~ \
useperlio=$(USE_PERLIO) ~ \
use64bitint=$(USE_64_BIT_INT) ~ \
+ uselongdouble=$(USE_LONG_DOUBLE) ~ \
uselargefiles=$(USE_LARGE_FILES) ~ \
usesitecustomize=$(USE_SITECUST) ~ \
LINK_FLAGS=$(LINK_FLAGS) ~ \
@echo #undef HAS_ATOLL>>$@
@echo #undef HAS_STRTOLL>>$@
@echo #undef HAS_STRTOULL>>$@
+ @echo #undef Size_t_size>>$@
@echo #undef IVTYPE>>$@
@echo #undef UVTYPE>>$@
@echo #undef IVSIZE>>$@
@echo #undef UVxf>>$@
@echo #undef UVXf>>$@
@echo #undef USE_64_BIT_INT>>$@
- @echo #undef Size_t_size>>$@
+ @echo #undef Gconvert>>$@
+ @echo #undef HAS_FREXPL>>$@
+ @echo #undef HAS_ISNANL>>$@
+ @echo #undef HAS_MODFL>>$@
+ @echo #undef HAS_MODFL_PROTO>>$@
+ @echo #undef HAS_SQRTL>>$@
+ @echo #undef HAS_STRTOLD>>$@
+ @echo #undef PERL_PRIfldbl>>$@
+ @echo #undef PERL_PRIgldbl>>$@
+ @echo #undef PERL_PRIeldbl>>$@
+ @echo #undef PERL_SCNfldbl>>$@
+ @echo #undef NVTYPE>>$@
+ @echo #undef NVSIZE>>$@
+ @echo #undef NV_OVERFLOWS_INTEGERS_AT>>$@
+ @echo #undef NVef>>$@
+ @echo #undef NVff>>$@
+ @echo #undef NVgf>>$@
+ @echo #undef USE_LONG_DOUBLE>>$@
.IF "$(USE_LARGE_FILES)"=="define"
@echo #define Off_t $(INT64)>>$@
@echo #define LSEEKSIZE ^8>>$@
@echo #define UVTYPE unsigned $(INT64)>>$@
@echo #define IVSIZE ^8>>$@
@echo #define UVSIZE ^8>>$@
+.IF "$(USE_LONG_DOUBLE)"=="define"
+ @echo #define NV_PRESERVES_UV>>$@
+ @echo #define NV_PRESERVES_UV_BITS 64>>$@
+.ELSE
@echo #undef NV_PRESERVES_UV>>$@
@echo #define NV_PRESERVES_UV_BITS 53>>$@
+.ENDIF
@echo #define IVdf "I64d">>$@
@echo #define UVuf "I64u">>$@
@echo #define UVof "I64o">>$@
@echo #define UVXf "lX">>$@
@echo #undef USE_64_BIT_INT>>$@
.ENDIF
+.IF "$(USE_LONG_DOUBLE)"=="define"
+ @echo #define Gconvert(x,n,t,b) sprintf((b),"%.*""Lg",(n),(x))>>$@
+ @echo #define HAS_FREXPL>>$@
+ @echo #define HAS_ISNANL>>$@
+ @echo #define HAS_MODFL>>$@
+ @echo #define HAS_MODFL_PROTO>>$@
+ @echo #define HAS_SQRTL>>$@
+ @echo #define HAS_STRTOLD>>$@
+ @echo #define PERL_PRIfldbl "Lf">>$@
+ @echo #define PERL_PRIgldbl "Lg">>$@
+ @echo #define PERL_PRIeldbl "Le">>$@
+ @echo #define PERL_SCNfldbl "Lf">>$@
+ @echo #define NVTYPE long double>>$@
+ @echo #define NVSIZE ^12>>$@
+ @echo #define NV_OVERFLOWS_INTEGERS_AT 256.0*256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0*2.0*2.0*2.0>>$@
+ @echo #define NVef "Le">>$@
+ @echo #define NVff "Lf">>$@
+ @echo #define NVgf "Lg">>$@
+ @echo #define USE_LONG_DOUBLE>>$@
+.ELSE
+ @echo #define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))>>$@
+ @echo #undef HAS_FREXPL>>$@
+ @echo #undef HAS_ISNANL>>$@
+ @echo #undef HAS_MODFL>>$@
+ @echo #undef HAS_MODFL_PROTO>>$@
+ @echo #undef HAS_SQRTL>>$@
+ @echo #undef HAS_STRTOLD>>$@
+ @echo #undef PERL_PRIfldbl>>$@
+ @echo #undef PERL_PRIgldbl>>$@
+ @echo #undef PERL_PRIeldbl>>$@
+ @echo #undef PERL_SCNfldbl>>$@
+ @echo #define NVTYPE double>>$@
+ @echo #define NVSIZE ^8>>$@
+ @echo #define NV_OVERFLOWS_INTEGERS_AT 256.0*256.0*256.0*256.0*256.0*256.0*2.0*2.0*2.0*2.0*2.0>>$@
+ @echo #define NVef "e">>$@
+ @echo #define NVff "f">>$@
+ @echo #define NVgf "g">>$@
+ @echo #undef USE_LONG_DOUBLE>>$@
+.ENDIF
@echo #endif>>$@
..\git_version.h : $(MINIPERL) ..\make_patchnum.pl
copy ..\README.tw ..\pod\perltw.pod
copy ..\README.vos ..\pod\perlvos.pod
copy ..\README.win32 ..\pod\perlwin32.pod
- copy ..\pod\perldelta.pod ..\pod\perl5215delta.pod
+ copy ..\pod\perldelta.pod ..\pod\perl5216delta.pod
$(PERLEXE) $(PL2BAT) $(UTILS)
$(MINIPERL) -I..\lib ..\autodoc.pl ..
$(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q ..
-if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API
-if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS
-cd $(PODDIR) && del /f *.html *.bat roffitall \
- perl5215delta.pod perlaix.pod perlamiga.pod perlandroid.pod \
+ perl5216delta.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 \
perl5213delta.pod \
perl5214delta.pod \
perl5215delta.pod \
+ perl5216delta.pod \
perl561delta.pod \
perl56delta.pod \
perl581delta.pod \
perl5213delta.man \
perl5214delta.man \
perl5215delta.man \
+ perl5216delta.man \
perl561delta.man \
perl56delta.man \
perl581delta.man \
perl5213delta.html \
perl5214delta.html \
perl5215delta.html \
+ perl5216delta.html \
perl561delta.html \
perl56delta.html \
perl581delta.html \
perl5213delta.tex \
perl5214delta.tex \
perl5215delta.tex \
+ perl5216delta.tex \
perl561delta.tex \
perl56delta.tex \
perl581delta.tex \
const int *handles);
static int do_spawnvp_handles(int mode, const char *cmdname,
const char * const *argv, const int *handles);
+static PerlIO * do_popen(const char *mode, const char *command, IV narg,
+ SV **args);
static long find_pid(pTHX_ int pid);
static void remove_dead_process(long child);
static int terminate_process(DWORD pid, HANDLE process_handle, int sig);
static long filetime_to_clock(PFILETIME ft);
static BOOL filetime_from_time(PFILETIME ft, time_t t);
static char* create_command_line(char *cname, STRLEN clen,
- const char * const *args);
+ const char * const *args);
static char* qualified_path(const char *cmd);
static void ansify_path(void);
static LRESULT win32_process_message(HWND hwnd, UINT msg,
DllExport PerlIO*
win32_popenlist(const char *mode, IV narg, SV **args)
{
- Perl_croak_nocontext("List form of pipe open not implemented");
- return NULL;
-}
+ get_shell();
-/*
- * a popen() clone that respects PERL5SHELL
- *
- * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
- */
+ return do_popen(mode, NULL, narg, args);
+}
-DllExport PerlIO*
-win32_popen(const char *command, const char *mode)
-{
-#ifdef USE_RTL_POPEN
- return _popen(command, mode);
-#else
+STATIC PerlIO*
+do_popen(const char *mode, const char *command, IV narg, SV **args) {
int p[2];
int handles[3];
int parent, child;
int childpid;
DWORD nhandle;
int lock_held = 0;
+ const char **args_pvs = NULL;
/* establish which ends read and write */
if (strchr(mode,'w')) {
{
dTHX;
- if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1)
- goto cleanup;
+ if (command) {
+ if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1)
+ goto cleanup;
+
+ }
+ else {
+ int i;
+
+ Newx(args_pvs, narg + 1 + w32_perlshell_items, const char *);
+ SAVEFREEPV(args_pvs);
+ for (i = 0; i < narg; ++i)
+ args_pvs[i] = SvPV_nolen(args[i]);
+ args_pvs[i] = NULL;
+
+ if ((childpid = do_spawnvp_handles(P_NOWAIT, args_pvs[0], args_pvs, handles)) == -1) {
+ if (errno == ENOEXEC || errno == ENOENT) {
+ /* possible shell-builtin, invoke with shell */
+ Move(args_pvs, args_pvs+w32_perlshell_items, narg+1, const char *);
+ Copy(w32_perlshell_vec, args_pvs, w32_perlshell_items, const char *);
+ if ((childpid = do_spawnvp_handles(P_NOWAIT, args_pvs[0], args_pvs, handles)) == -1)
+ goto cleanup;
+ }
+ else
+ goto cleanup;
+ }
+ }
win32_close(p[child]);
win32_close(p[1]);
return (NULL);
+}
+
+/*
+ * a popen() clone that respects PERL5SHELL
+ *
+ * changed to return PerlIO* rather than FILE * by BKS, 11-11-2000
+ */
+DllExport PerlIO*
+win32_popen(const char *command, const char *mode)
+{
+#ifdef USE_RTL_POPEN
+ return _popen(command, mode);
+#else
+ return do_popen(mode, command, 0, NULL);
#endif /* USE_RTL_POPEN */
}
if (GetLastError() != NO_ERROR)
{
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ PerlIO_save_errno(f);
return -1;
}
else
else
{
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ PerlIO_save_errno(f);
return -1;
}
}
{
char *path = SvPV_nolen(*args);
DWORD access = 0;
- DWORD share = 0;
+ /* CRT uses _SH_DENYNO for open(), this the Win32 equivelent */
+ DWORD share = FILE_SHARE_READ | FILE_SHARE_WRITE;
DWORD create = -1;
DWORD attr = FILE_ATTRIBUTE_NORMAL;
+ if (stricmp(path, "/dev/null")==0)
+ path = "NUL";
if (*mode == '#')
{
/* sysopen - imode is UNIX-like O_RDONLY etc.
SETERRNO(EINVAL,LIB$_INVARG);
return NULL;
}
- if (!(access & GENERIC_WRITE))
- share = FILE_SHARE_READ;
h = CreateFile(path,access,share,NULL,create,attr,NULL);
if (h == INVALID_HANDLE_VALUE)
{
if (GetLastError() != NO_ERROR)
{
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ PerlIO_save_errno(f);
return -1;
}
else
else
{
PerlIOBase(f)->flags |= PERLIO_F_ERROR;
+ PerlIO_save_errno(f);
return -1;
}
}
projects / platform / upstream / perl.git / commitdiff